       SUBROUTINE DRTU1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
     1IBUGD2,IFOUND,IERROR)
C
C     PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES
C              FOR ROMAN TRIPLEX UPPER CASE (PART 1).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/4
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH     1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MARCH     1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IOP
      CHARACTER*4 IBUGD2
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IOPERA
C
C---------------------------------------------------------------------
C
      DIMENSION IOP(*)
      DIMENSION X(*)
      DIMENSION Y(*)
C
      DIMENSION IOPERA(300)
      DIMENSION IX(300)
      DIMENSION IY(300)
C
      DIMENSION IXMIND(30)
      DIMENSION IXMAXD(30)
      DIMENSION IXDELD(30)
      DIMENSION ISTARD(30)
      DIMENSION NUMCOO(30)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C     DEFINE CHARACTER   3001--UPPER CASE A
C
      DATA IOPERA(   1),IX(   1),IY(   1)/'MOVE',   0,  12/
      DATA IOPERA(   2),IX(   2),IY(   2)/'DRAW',  -7,  -8/
      DATA IOPERA(   3),IX(   3),IY(   3)/'MOVE',  -1,   9/
      DATA IOPERA(   4),IX(   4),IY(   4)/'DRAW',   5,  -9/
      DATA IOPERA(   5),IX(   5),IY(   5)/'MOVE',   0,   9/
      DATA IOPERA(   6),IX(   6),IY(   6)/'DRAW',   6,  -9/
      DATA IOPERA(   7),IX(   7),IY(   7)/'MOVE',   0,  12/
      DATA IOPERA(   8),IX(   8),IY(   8)/'DRAW',   7,  -9/
      DATA IOPERA(   9),IX(   9),IY(   9)/'MOVE',  -5,  -3/
      DATA IOPERA(  10),IX(  10),IY(  10)/'DRAW',   4,  -3/
      DATA IOPERA(  11),IX(  11),IY(  11)/'MOVE',  -9,  -9/
      DATA IOPERA(  12),IX(  12),IY(  12)/'DRAW',  -3,  -9/
      DATA IOPERA(  13),IX(  13),IY(  13)/'MOVE',   2,  -9/
      DATA IOPERA(  14),IX(  14),IY(  14)/'DRAW',   9,  -9/
      DATA IOPERA(  15),IX(  15),IY(  15)/'MOVE',  -7,  -8/
      DATA IOPERA(  16),IX(  16),IY(  16)/'DRAW',  -8,  -9/
      DATA IOPERA(  17),IX(  17),IY(  17)/'MOVE',  -7,  -8/
      DATA IOPERA(  18),IX(  18),IY(  18)/'DRAW',  -5,  -9/
      DATA IOPERA(  19),IX(  19),IY(  19)/'MOVE',   5,  -8/
      DATA IOPERA(  20),IX(  20),IY(  20)/'DRAW',   3,  -9/
      DATA IOPERA(  21),IX(  21),IY(  21)/'MOVE',   5,  -7/
      DATA IOPERA(  22),IX(  22),IY(  22)/'DRAW',   4,  -9/
      DATA IOPERA(  23),IX(  23),IY(  23)/'MOVE',   6,  -7/
      DATA IOPERA(  24),IX(  24),IY(  24)/'DRAW',   8,  -9/
C
      DATA IXMIND(   1)/ -10/
      DATA IXMAXD(   1)/  10/
      DATA IXDELD(   1)/  20/
      DATA ISTARD(   1)/   1/
      DATA NUMCOO(   1)/  24/
C
C     DEFINE CHARACTER   3002--UPPER CASE B
C
      DATA IOPERA(  25),IX(  25),IY(  25)/'MOVE',  -6,  12/
      DATA IOPERA(  26),IX(  26),IY(  26)/'DRAW',  -6,  -9/
      DATA IOPERA(  27),IX(  27),IY(  27)/'MOVE',  -5,  11/
      DATA IOPERA(  28),IX(  28),IY(  28)/'DRAW',  -5,  -8/
      DATA IOPERA(  29),IX(  29),IY(  29)/'MOVE',  -4,  12/
      DATA IOPERA(  30),IX(  30),IY(  30)/'DRAW',  -4,  -9/
      DATA IOPERA(  31),IX(  31),IY(  31)/'MOVE',  -9,  12/
      DATA IOPERA(  32),IX(  32),IY(  32)/'DRAW',   3,  12/
      DATA IOPERA(  33),IX(  33),IY(  33)/'DRAW',   6,  11/
      DATA IOPERA(  34),IX(  34),IY(  34)/'DRAW',   7,  10/
      DATA IOPERA(  35),IX(  35),IY(  35)/'DRAW',   8,   8/
      DATA IOPERA(  36),IX(  36),IY(  36)/'DRAW',   8,   6/
      DATA IOPERA(  37),IX(  37),IY(  37)/'DRAW',   7,   4/
      DATA IOPERA(  38),IX(  38),IY(  38)/'DRAW',   6,   3/
      DATA IOPERA(  39),IX(  39),IY(  39)/'DRAW',   3,   2/
      DATA IOPERA(  40),IX(  40),IY(  40)/'MOVE',   6,  10/
      DATA IOPERA(  41),IX(  41),IY(  41)/'DRAW',   7,   8/
      DATA IOPERA(  42),IX(  42),IY(  42)/'DRAW',   7,   6/
      DATA IOPERA(  43),IX(  43),IY(  43)/'DRAW',   6,   4/
      DATA IOPERA(  44),IX(  44),IY(  44)/'MOVE',   3,  12/
      DATA IOPERA(  45),IX(  45),IY(  45)/'DRAW',   5,  11/
      DATA IOPERA(  46),IX(  46),IY(  46)/'DRAW',   6,   9/
      DATA IOPERA(  47),IX(  47),IY(  47)/'DRAW',   6,   5/
      DATA IOPERA(  48),IX(  48),IY(  48)/'DRAW',   5,   3/
      DATA IOPERA(  49),IX(  49),IY(  49)/'DRAW',   3,   2/
      DATA IOPERA(  50),IX(  50),IY(  50)/'MOVE',  -4,   2/
      DATA IOPERA(  51),IX(  51),IY(  51)/'DRAW',   3,   2/
      DATA IOPERA(  52),IX(  52),IY(  52)/'DRAW',   6,   1/
      DATA IOPERA(  53),IX(  53),IY(  53)/'DRAW',   7,   0/
      DATA IOPERA(  54),IX(  54),IY(  54)/'DRAW',   8,  -2/
      DATA IOPERA(  55),IX(  55),IY(  55)/'DRAW',   8,  -5/
      DATA IOPERA(  56),IX(  56),IY(  56)/'DRAW',   7,  -7/
      DATA IOPERA(  57),IX(  57),IY(  57)/'DRAW',   6,  -8/
      DATA IOPERA(  58),IX(  58),IY(  58)/'DRAW',   3,  -9/
      DATA IOPERA(  59),IX(  59),IY(  59)/'DRAW',  -9,  -9/
      DATA IOPERA(  60),IX(  60),IY(  60)/'MOVE',   6,   0/
      DATA IOPERA(  61),IX(  61),IY(  61)/'DRAW',   7,  -2/
      DATA IOPERA(  62),IX(  62),IY(  62)/'DRAW',   7,  -5/
      DATA IOPERA(  63),IX(  63),IY(  63)/'DRAW',   6,  -7/
      DATA IOPERA(  64),IX(  64),IY(  64)/'MOVE',   3,   2/
      DATA IOPERA(  65),IX(  65),IY(  65)/'DRAW',   5,   1/
      DATA IOPERA(  66),IX(  66),IY(  66)/'DRAW',   6,  -1/
      DATA IOPERA(  67),IX(  67),IY(  67)/'DRAW',   6,  -6/
      DATA IOPERA(  68),IX(  68),IY(  68)/'DRAW',   5,  -8/
      DATA IOPERA(  69),IX(  69),IY(  69)/'DRAW',   3,  -9/
      DATA IOPERA(  70),IX(  70),IY(  70)/'MOVE',  -8,  12/
      DATA IOPERA(  71),IX(  71),IY(  71)/'DRAW',  -6,  11/
      DATA IOPERA(  72),IX(  72),IY(  72)/'MOVE',  -7,  12/
      DATA IOPERA(  73),IX(  73),IY(  73)/'DRAW',  -6,  10/
      DATA IOPERA(  74),IX(  74),IY(  74)/'MOVE',  -3,  12/
      DATA IOPERA(  75),IX(  75),IY(  75)/'DRAW',  -4,  10/
      DATA IOPERA(  76),IX(  76),IY(  76)/'MOVE',  -2,  12/
      DATA IOPERA(  77),IX(  77),IY(  77)/'DRAW',  -4,  11/
      DATA IOPERA(  78),IX(  78),IY(  78)/'MOVE',  -6,  -8/
      DATA IOPERA(  79),IX(  79),IY(  79)/'DRAW',  -8,  -9/
      DATA IOPERA(  80),IX(  80),IY(  80)/'MOVE',  -6,  -7/
      DATA IOPERA(  81),IX(  81),IY(  81)/'DRAW',  -7,  -9/
      DATA IOPERA(  82),IX(  82),IY(  82)/'MOVE',  -4,  -7/
      DATA IOPERA(  83),IX(  83),IY(  83)/'DRAW',  -3,  -9/
      DATA IOPERA(  84),IX(  84),IY(  84)/'MOVE',  -4,  -8/
      DATA IOPERA(  85),IX(  85),IY(  85)/'DRAW',  -2,  -9/
C
      DATA IXMIND(   2)/ -11/
      DATA IXMAXD(   2)/  11/
      DATA IXDELD(   2)/  22/
      DATA ISTARD(   2)/  25/
      DATA NUMCOO(   2)/  61/
C
C     DEFINE CHARACTER   3003--UPPER CASE C
C
      DATA IOPERA(  86),IX(  86),IY(  86)/'MOVE',   6,   9/
      DATA IOPERA(  87),IX(  87),IY(  87)/'DRAW',   7,  12/
      DATA IOPERA(  88),IX(  88),IY(  88)/'DRAW',   7,   6/
      DATA IOPERA(  89),IX(  89),IY(  89)/'DRAW',   6,   9/
      DATA IOPERA(  90),IX(  90),IY(  90)/'DRAW',   4,  11/
      DATA IOPERA(  91),IX(  91),IY(  91)/'DRAW',   2,  12/
      DATA IOPERA(  92),IX(  92),IY(  92)/'DRAW',  -1,  12/
      DATA IOPERA(  93),IX(  93),IY(  93)/'DRAW',  -4,  11/
      DATA IOPERA(  94),IX(  94),IY(  94)/'DRAW',  -6,   9/
      DATA IOPERA(  95),IX(  95),IY(  95)/'DRAW',  -7,   7/
      DATA IOPERA(  96),IX(  96),IY(  96)/'DRAW',  -8,   4/
      DATA IOPERA(  97),IX(  97),IY(  97)/'DRAW',  -8,  -1/
      DATA IOPERA(  98),IX(  98),IY(  98)/'DRAW',  -7,  -4/
      DATA IOPERA(  99),IX(  99),IY(  99)/'DRAW',  -6,  -6/
      DATA IOPERA( 100),IX( 100),IY( 100)/'DRAW',  -4,  -8/
      DATA IOPERA( 101),IX( 101),IY( 101)/'DRAW',  -1,  -9/
      DATA IOPERA( 102),IX( 102),IY( 102)/'DRAW',   2,  -9/
      DATA IOPERA( 103),IX( 103),IY( 103)/'DRAW',   4,  -8/
      DATA IOPERA( 104),IX( 104),IY( 104)/'DRAW',   6,  -6/
      DATA IOPERA( 105),IX( 105),IY( 105)/'DRAW',   7,  -4/
      DATA IOPERA( 106),IX( 106),IY( 106)/'MOVE',  -5,   9/
      DATA IOPERA( 107),IX( 107),IY( 107)/'DRAW',  -6,   7/
      DATA IOPERA( 108),IX( 108),IY( 108)/'DRAW',  -7,   4/
      DATA IOPERA( 109),IX( 109),IY( 109)/'DRAW',  -7,  -1/
      DATA IOPERA( 110),IX( 110),IY( 110)/'DRAW',  -6,  -4/
      DATA IOPERA( 111),IX( 111),IY( 111)/'DRAW',  -5,  -6/
      DATA IOPERA( 112),IX( 112),IY( 112)/'MOVE',  -1,  12/
      DATA IOPERA( 113),IX( 113),IY( 113)/'DRAW',  -3,  11/
      DATA IOPERA( 114),IX( 114),IY( 114)/'DRAW',  -5,   8/
      DATA IOPERA( 115),IX( 115),IY( 115)/'DRAW',  -6,   4/
      DATA IOPERA( 116),IX( 116),IY( 116)/'DRAW',  -6,  -1/
      DATA IOPERA( 117),IX( 117),IY( 117)/'DRAW',  -5,  -5/
      DATA IOPERA( 118),IX( 118),IY( 118)/'DRAW',  -3,  -8/
      DATA IOPERA( 119),IX( 119),IY( 119)/'DRAW',  -1,  -9/
C
      DATA IXMIND(   3)/ -11/
      DATA IXMAXD(   3)/  10/
      DATA IXDELD(   3)/  21/
      DATA ISTARD(   3)/  86/
      DATA NUMCOO(   3)/  34/
C
C     DEFINE CHARACTER   3004--UPPER CASE D
C
      DATA IOPERA( 120),IX( 120),IY( 120)/'MOVE',  -6,  12/
      DATA IOPERA( 121),IX( 121),IY( 121)/'DRAW',  -6,  -9/
      DATA IOPERA( 122),IX( 122),IY( 122)/'MOVE',  -5,  11/
      DATA IOPERA( 123),IX( 123),IY( 123)/'DRAW',  -5,  -8/
      DATA IOPERA( 124),IX( 124),IY( 124)/'MOVE',  -4,  12/
      DATA IOPERA( 125),IX( 125),IY( 125)/'DRAW',  -4,  -9/
      DATA IOPERA( 126),IX( 126),IY( 126)/'MOVE',  -9,  12/
      DATA IOPERA( 127),IX( 127),IY( 127)/'DRAW',   1,  12/
      DATA IOPERA( 128),IX( 128),IY( 128)/'DRAW',   4,  11/
      DATA IOPERA( 129),IX( 129),IY( 129)/'DRAW',   6,   9/
      DATA IOPERA( 130),IX( 130),IY( 130)/'DRAW',   7,   7/
      DATA IOPERA( 131),IX( 131),IY( 131)/'DRAW',   8,   4/
      DATA IOPERA( 132),IX( 132),IY( 132)/'DRAW',   8,  -1/
      DATA IOPERA( 133),IX( 133),IY( 133)/'DRAW',   7,  -4/
      DATA IOPERA( 134),IX( 134),IY( 134)/'DRAW',   6,  -6/
      DATA IOPERA( 135),IX( 135),IY( 135)/'DRAW',   4,  -8/
      DATA IOPERA( 136),IX( 136),IY( 136)/'DRAW',   1,  -9/
      DATA IOPERA( 137),IX( 137),IY( 137)/'DRAW',  -9,  -9/
      DATA IOPERA( 138),IX( 138),IY( 138)/'MOVE',   5,   9/
      DATA IOPERA( 139),IX( 139),IY( 139)/'DRAW',   6,   7/
      DATA IOPERA( 140),IX( 140),IY( 140)/'DRAW',   7,   4/
      DATA IOPERA( 141),IX( 141),IY( 141)/'DRAW',   7,  -1/
      DATA IOPERA( 142),IX( 142),IY( 142)/'DRAW',   6,  -4/
      DATA IOPERA( 143),IX( 143),IY( 143)/'DRAW',   5,  -6/
      DATA IOPERA( 144),IX( 144),IY( 144)/'MOVE',   1,  12/
      DATA IOPERA( 145),IX( 145),IY( 145)/'DRAW',   3,  11/
      DATA IOPERA( 146),IX( 146),IY( 146)/'DRAW',   5,   8/
      DATA IOPERA( 147),IX( 147),IY( 147)/'DRAW',   6,   4/
      DATA IOPERA( 148),IX( 148),IY( 148)/'DRAW',   6,  -1/
      DATA IOPERA( 149),IX( 149),IY( 149)/'DRAW',   5,  -5/
      DATA IOPERA( 150),IX( 150),IY( 150)/'DRAW',   3,  -8/
      DATA IOPERA( 151),IX( 151),IY( 151)/'DRAW',   1,  -9/
      DATA IOPERA( 152),IX( 152),IY( 152)/'MOVE',  -8,  12/
      DATA IOPERA( 153),IX( 153),IY( 153)/'DRAW',  -6,  11/
      DATA IOPERA( 154),IX( 154),IY( 154)/'MOVE',  -7,  12/
      DATA IOPERA( 155),IX( 155),IY( 155)/'DRAW',  -6,  10/
      DATA IOPERA( 156),IX( 156),IY( 156)/'MOVE',  -3,  12/
      DATA IOPERA( 157),IX( 157),IY( 157)/'DRAW',  -4,  10/
      DATA IOPERA( 158),IX( 158),IY( 158)/'MOVE',  -2,  12/
      DATA IOPERA( 159),IX( 159),IY( 159)/'DRAW',  -4,  11/
      DATA IOPERA( 160),IX( 160),IY( 160)/'MOVE',  -6,  -8/
      DATA IOPERA( 161),IX( 161),IY( 161)/'DRAW',  -8,  -9/
      DATA IOPERA( 162),IX( 162),IY( 162)/'MOVE',  -6,  -7/
      DATA IOPERA( 163),IX( 163),IY( 163)/'DRAW',  -7,  -9/
      DATA IOPERA( 164),IX( 164),IY( 164)/'MOVE',  -4,  -7/
      DATA IOPERA( 165),IX( 165),IY( 165)/'DRAW',  -3,  -9/
      DATA IOPERA( 166),IX( 166),IY( 166)/'MOVE',  -4,  -8/
      DATA IOPERA( 167),IX( 167),IY( 167)/'DRAW',  -2,  -9/
C
      DATA IXMIND(   4)/ -11/
      DATA IXMAXD(   4)/  11/
      DATA IXDELD(   4)/  22/
      DATA ISTARD(   4)/ 120/
      DATA NUMCOO(   4)/  48/
C
C     DEFINE CHARACTER   3005--UPPER CASE E
C
      DATA IOPERA( 168),IX( 168),IY( 168)/'MOVE',  -6,  12/
      DATA IOPERA( 169),IX( 169),IY( 169)/'DRAW',  -6,  -9/
      DATA IOPERA( 170),IX( 170),IY( 170)/'MOVE',  -5,  11/
      DATA IOPERA( 171),IX( 171),IY( 171)/'DRAW',  -5,  -8/
      DATA IOPERA( 172),IX( 172),IY( 172)/'MOVE',  -4,  12/
      DATA IOPERA( 173),IX( 173),IY( 173)/'DRAW',  -4,  -9/
      DATA IOPERA( 174),IX( 174),IY( 174)/'MOVE',  -9,  12/
      DATA IOPERA( 175),IX( 175),IY( 175)/'DRAW',   7,  12/
      DATA IOPERA( 176),IX( 176),IY( 176)/'DRAW',   7,   6/
      DATA IOPERA( 177),IX( 177),IY( 177)/'MOVE',  -4,   2/
      DATA IOPERA( 178),IX( 178),IY( 178)/'DRAW',   2,   2/
      DATA IOPERA( 179),IX( 179),IY( 179)/'MOVE',   2,   6/
      DATA IOPERA( 180),IX( 180),IY( 180)/'DRAW',   2,  -2/
      DATA IOPERA( 181),IX( 181),IY( 181)/'MOVE',  -9,  -9/
      DATA IOPERA( 182),IX( 182),IY( 182)/'DRAW',   7,  -9/
      DATA IOPERA( 183),IX( 183),IY( 183)/'DRAW',   7,  -3/
      DATA IOPERA( 184),IX( 184),IY( 184)/'MOVE',  -8,  12/
      DATA IOPERA( 185),IX( 185),IY( 185)/'DRAW',  -6,  11/
      DATA IOPERA( 186),IX( 186),IY( 186)/'MOVE',  -7,  12/
      DATA IOPERA( 187),IX( 187),IY( 187)/'DRAW',  -6,  10/
      DATA IOPERA( 188),IX( 188),IY( 188)/'MOVE',  -3,  12/
      DATA IOPERA( 189),IX( 189),IY( 189)/'DRAW',  -4,  10/
      DATA IOPERA( 190),IX( 190),IY( 190)/'MOVE',  -2,  12/
      DATA IOPERA( 191),IX( 191),IY( 191)/'DRAW',  -4,  11/
      DATA IOPERA( 192),IX( 192),IY( 192)/'MOVE',   2,  12/
      DATA IOPERA( 193),IX( 193),IY( 193)/'DRAW',   7,  11/
      DATA IOPERA( 194),IX( 194),IY( 194)/'MOVE',   4,  12/
      DATA IOPERA( 195),IX( 195),IY( 195)/'DRAW',   7,  10/
      DATA IOPERA( 196),IX( 196),IY( 196)/'MOVE',   5,  12/
      DATA IOPERA( 197),IX( 197),IY( 197)/'DRAW',   7,   9/
      DATA IOPERA( 198),IX( 198),IY( 198)/'MOVE',   6,  12/
      DATA IOPERA( 199),IX( 199),IY( 199)/'DRAW',   7,   6/
      DATA IOPERA( 200),IX( 200),IY( 200)/'MOVE',   2,   6/
      DATA IOPERA( 201),IX( 201),IY( 201)/'DRAW',   1,   2/
      DATA IOPERA( 202),IX( 202),IY( 202)/'DRAW',   2,  -2/
      DATA IOPERA( 203),IX( 203),IY( 203)/'MOVE',   2,   4/
      DATA IOPERA( 204),IX( 204),IY( 204)/'DRAW',   0,   2/
      DATA IOPERA( 205),IX( 205),IY( 205)/'DRAW',   2,   0/
      DATA IOPERA( 206),IX( 206),IY( 206)/'MOVE',   2,   3/
      DATA IOPERA( 207),IX( 207),IY( 207)/'DRAW',  -2,   2/
      DATA IOPERA( 208),IX( 208),IY( 208)/'DRAW',   2,   1/
      DATA IOPERA( 209),IX( 209),IY( 209)/'MOVE',  -6,  -8/
      DATA IOPERA( 210),IX( 210),IY( 210)/'DRAW',  -8,  -9/
      DATA IOPERA( 211),IX( 211),IY( 211)/'MOVE',  -6,  -7/
      DATA IOPERA( 212),IX( 212),IY( 212)/'DRAW',  -7,  -9/
      DATA IOPERA( 213),IX( 213),IY( 213)/'MOVE',  -4,  -7/
      DATA IOPERA( 214),IX( 214),IY( 214)/'DRAW',  -3,  -9/
      DATA IOPERA( 215),IX( 215),IY( 215)/'MOVE',  -4,  -8/
      DATA IOPERA( 216),IX( 216),IY( 216)/'DRAW',  -2,  -9/
      DATA IOPERA( 217),IX( 217),IY( 217)/'MOVE',   2,  -9/
      DATA IOPERA( 218),IX( 218),IY( 218)/'DRAW',   7,  -8/
      DATA IOPERA( 219),IX( 219),IY( 219)/'MOVE',   4,  -9/
      DATA IOPERA( 220),IX( 220),IY( 220)/'DRAW',   7,  -7/
      DATA IOPERA( 221),IX( 221),IY( 221)/'MOVE',   5,  -9/
      DATA IOPERA( 222),IX( 222),IY( 222)/'DRAW',   7,  -6/
      DATA IOPERA( 223),IX( 223),IY( 223)/'MOVE',   6,  -9/
      DATA IOPERA( 224),IX( 224),IY( 224)/'DRAW',   7,  -3/
C
      DATA IXMIND(   5)/ -11/
      DATA IXMAXD(   5)/  10/
      DATA IXDELD(   5)/  21/
      DATA ISTARD(   5)/ 168/
      DATA NUMCOO(   5)/  57/
C
C     DEFINE CHARACTER   3006--UPPER CASE F
C
      DATA IOPERA( 225),IX( 225),IY( 225)/'MOVE',  -6,  12/
      DATA IOPERA( 226),IX( 226),IY( 226)/'DRAW',  -6,  -9/
      DATA IOPERA( 227),IX( 227),IY( 227)/'MOVE',  -5,  11/
      DATA IOPERA( 228),IX( 228),IY( 228)/'DRAW',  -5,  -8/
      DATA IOPERA( 229),IX( 229),IY( 229)/'MOVE',  -4,  12/
      DATA IOPERA( 230),IX( 230),IY( 230)/'DRAW',  -4,  -9/
      DATA IOPERA( 231),IX( 231),IY( 231)/'MOVE',  -9,  12/
      DATA IOPERA( 232),IX( 232),IY( 232)/'DRAW',   7,  12/
      DATA IOPERA( 233),IX( 233),IY( 233)/'DRAW',   7,   6/
      DATA IOPERA( 234),IX( 234),IY( 234)/'MOVE',  -4,   2/
      DATA IOPERA( 235),IX( 235),IY( 235)/'DRAW',   2,   2/
      DATA IOPERA( 236),IX( 236),IY( 236)/'MOVE',   2,   6/
      DATA IOPERA( 237),IX( 237),IY( 237)/'DRAW',   2,  -2/
      DATA IOPERA( 238),IX( 238),IY( 238)/'MOVE',  -9,  -9/
      DATA IOPERA( 239),IX( 239),IY( 239)/'DRAW',  -1,  -9/
      DATA IOPERA( 240),IX( 240),IY( 240)/'MOVE',  -8,  12/
      DATA IOPERA( 241),IX( 241),IY( 241)/'DRAW',  -6,  11/
      DATA IOPERA( 242),IX( 242),IY( 242)/'MOVE',  -7,  12/
      DATA IOPERA( 243),IX( 243),IY( 243)/'DRAW',  -6,  10/
      DATA IOPERA( 244),IX( 244),IY( 244)/'MOVE',  -3,  12/
      DATA IOPERA( 245),IX( 245),IY( 245)/'DRAW',  -4,  10/
      DATA IOPERA( 246),IX( 246),IY( 246)/'MOVE',  -2,  12/
      DATA IOPERA( 247),IX( 247),IY( 247)/'DRAW',  -4,  11/
      DATA IOPERA( 248),IX( 248),IY( 248)/'MOVE',   2,  12/
      DATA IOPERA( 249),IX( 249),IY( 249)/'DRAW',   7,  11/
      DATA IOPERA( 250),IX( 250),IY( 250)/'MOVE',   4,  12/
      DATA IOPERA( 251),IX( 251),IY( 251)/'DRAW',   7,  10/
      DATA IOPERA( 252),IX( 252),IY( 252)/'MOVE',   5,  12/
      DATA IOPERA( 253),IX( 253),IY( 253)/'DRAW',   7,   9/
      DATA IOPERA( 254),IX( 254),IY( 254)/'MOVE',   6,  12/
      DATA IOPERA( 255),IX( 255),IY( 255)/'DRAW',   7,   6/
      DATA IOPERA( 256),IX( 256),IY( 256)/'MOVE',   2,   6/
      DATA IOPERA( 257),IX( 257),IY( 257)/'DRAW',   1,   2/
      DATA IOPERA( 258),IX( 258),IY( 258)/'DRAW',   2,  -2/
      DATA IOPERA( 259),IX( 259),IY( 259)/'MOVE',   2,   4/
      DATA IOPERA( 260),IX( 260),IY( 260)/'DRAW',   0,   2/
      DATA IOPERA( 261),IX( 261),IY( 261)/'DRAW',   2,   0/
      DATA IOPERA( 262),IX( 262),IY( 262)/'MOVE',   2,   3/
      DATA IOPERA( 263),IX( 263),IY( 263)/'DRAW',  -2,   2/
      DATA IOPERA( 264),IX( 264),IY( 264)/'DRAW',   2,   1/
      DATA IOPERA( 265),IX( 265),IY( 265)/'MOVE',  -6,  -8/
      DATA IOPERA( 266),IX( 266),IY( 266)/'DRAW',  -8,  -9/
      DATA IOPERA( 267),IX( 267),IY( 267)/'MOVE',  -6,  -7/
      DATA IOPERA( 268),IX( 268),IY( 268)/'DRAW',  -7,  -9/
      DATA IOPERA( 269),IX( 269),IY( 269)/'MOVE',  -4,  -7/
      DATA IOPERA( 270),IX( 270),IY( 270)/'DRAW',  -3,  -9/
      DATA IOPERA( 271),IX( 271),IY( 271)/'MOVE',  -4,  -8/
      DATA IOPERA( 272),IX( 272),IY( 272)/'DRAW',  -2,  -9/
C
      DATA IXMIND(   6)/ -11/
      DATA IXMAXD(   6)/   9/
      DATA IXDELD(   6)/  20/
      DATA ISTARD(   6)/ 225/
      DATA NUMCOO(   6)/  48/
C
C-----START POINT-----------------------------------------------------
C
      IFOUND='YES'
      IERROR='NO'
C
      NUMCO=1
      ISTART=1
      ISTOP=1
      NC=1
C
C               ******************************************
C               **  TREAT THE ROMAN SIMPLEX UPPER CASE  **
C               **  HERSHEY CHARACTER SET CASE          **
C               ******************************************
C
C
      IF(IBUGD2.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DRTU1--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ICHARN
   52 FORMAT('ICHARN = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR
   59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               **************************************
C               **  STEP 2--                        **
C               **  EXTRACT THE COORDINATES         **
C               **  FOR THIS PARTICULAR CHARACTER.  **
C               **************************************
C
 1000 CONTINUE
      ISTART=ISTARD(ICHARN)
      NC=NUMCOO(ICHARN)
      ISTOP=ISTART+NC-1
      J=0
      DO1100I=ISTART,ISTOP
      J=J+1
      IOP(J)=IOPERA(I)
      X(J)=IX(I)
      Y(J)=IY(I)
 1100 CONTINUE
      NUMCO=J
      IXMINS=IXMIND(ICHARN)
      IXMAXS=IXMAXD(ICHARN)
      IXDELS=IXDELD(ICHARN)
C
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGD2.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DRTU1--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR
 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)ICHARN
 9013 FORMAT('ICHARN = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO
 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8)
      CALL DPWRST('XXX','BUG ')
      IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019
      DO9015I=1,NUMCO
      WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I)
 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9019 CONTINUE
      WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS
 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DRTU2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
     1IBUGD2,IFOUND,IERROR)
C
C     PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES
C              FOR ROMAN TRIPLEX UPPER CASE (PART 2).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/4
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH     1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MARCH     1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IOP
      CHARACTER*4 IBUGD2
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IOPERA
C
C---------------------------------------------------------------------
C
      DIMENSION IOP(*)
      DIMENSION X(*)
      DIMENSION Y(*)
C
      DIMENSION IOPERA(300)
      DIMENSION IX(300)
      DIMENSION IY(300)
C
      DIMENSION IXMIND(30)
      DIMENSION IXMAXD(30)
      DIMENSION IXDELD(30)
      DIMENSION ISTARD(30)
      DIMENSION NUMCOO(30)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C     DEFINE CHARACTER   3007--UPPER CASE G
C
      DATA IOPERA(   1),IX(   1),IY(   1)/'MOVE',   6,   9/
      DATA IOPERA(   2),IX(   2),IY(   2)/'DRAW',   7,  12/
      DATA IOPERA(   3),IX(   3),IY(   3)/'DRAW',   7,   6/
      DATA IOPERA(   4),IX(   4),IY(   4)/'DRAW',   6,   9/
      DATA IOPERA(   5),IX(   5),IY(   5)/'DRAW',   4,  11/
      DATA IOPERA(   6),IX(   6),IY(   6)/'DRAW',   2,  12/
      DATA IOPERA(   7),IX(   7),IY(   7)/'DRAW',  -1,  12/
      DATA IOPERA(   8),IX(   8),IY(   8)/'DRAW',  -4,  11/
      DATA IOPERA(   9),IX(   9),IY(   9)/'DRAW',  -6,   9/
      DATA IOPERA(  10),IX(  10),IY(  10)/'DRAW',  -7,   7/
      DATA IOPERA(  11),IX(  11),IY(  11)/'DRAW',  -8,   4/
      DATA IOPERA(  12),IX(  12),IY(  12)/'DRAW',  -8,  -1/
      DATA IOPERA(  13),IX(  13),IY(  13)/'DRAW',  -7,  -4/
      DATA IOPERA(  14),IX(  14),IY(  14)/'DRAW',  -6,  -6/
      DATA IOPERA(  15),IX(  15),IY(  15)/'DRAW',  -4,  -8/
      DATA IOPERA(  16),IX(  16),IY(  16)/'DRAW',  -1,  -9/
      DATA IOPERA(  17),IX(  17),IY(  17)/'DRAW',   2,  -9/
      DATA IOPERA(  18),IX(  18),IY(  18)/'DRAW',   4,  -8/
      DATA IOPERA(  19),IX(  19),IY(  19)/'DRAW',   6,  -8/
      DATA IOPERA(  20),IX(  20),IY(  20)/'DRAW',   7,  -9/
      DATA IOPERA(  21),IX(  21),IY(  21)/'DRAW',   7,  -1/
      DATA IOPERA(  22),IX(  22),IY(  22)/'MOVE',  -5,   9/
      DATA IOPERA(  23),IX(  23),IY(  23)/'DRAW',  -6,   7/
      DATA IOPERA(  24),IX(  24),IY(  24)/'DRAW',  -7,   4/
      DATA IOPERA(  25),IX(  25),IY(  25)/'DRAW',  -7,  -1/
      DATA IOPERA(  26),IX(  26),IY(  26)/'DRAW',  -6,  -4/
      DATA IOPERA(  27),IX(  27),IY(  27)/'DRAW',  -5,  -6/
      DATA IOPERA(  28),IX(  28),IY(  28)/'MOVE',  -1,  12/
      DATA IOPERA(  29),IX(  29),IY(  29)/'DRAW',  -3,  11/
      DATA IOPERA(  30),IX(  30),IY(  30)/'DRAW',  -5,   8/
      DATA IOPERA(  31),IX(  31),IY(  31)/'DRAW',  -6,   4/
      DATA IOPERA(  32),IX(  32),IY(  32)/'DRAW',  -6,  -1/
      DATA IOPERA(  33),IX(  33),IY(  33)/'DRAW',  -5,  -5/
      DATA IOPERA(  34),IX(  34),IY(  34)/'DRAW',  -3,  -8/
      DATA IOPERA(  35),IX(  35),IY(  35)/'DRAW',  -1,  -9/
      DATA IOPERA(  36),IX(  36),IY(  36)/'MOVE',   6,  -2/
      DATA IOPERA(  37),IX(  37),IY(  37)/'DRAW',   6,  -7/
      DATA IOPERA(  38),IX(  38),IY(  38)/'MOVE',   5,  -1/
      DATA IOPERA(  39),IX(  39),IY(  39)/'DRAW',   5,  -7/
      DATA IOPERA(  40),IX(  40),IY(  40)/'DRAW',   4,  -8/
      DATA IOPERA(  41),IX(  41),IY(  41)/'MOVE',   2,  -1/
      DATA IOPERA(  42),IX(  42),IY(  42)/'DRAW',  10,  -1/
      DATA IOPERA(  43),IX(  43),IY(  43)/'MOVE',   3,  -1/
      DATA IOPERA(  44),IX(  44),IY(  44)/'DRAW',   5,  -2/
      DATA IOPERA(  45),IX(  45),IY(  45)/'MOVE',   4,  -1/
      DATA IOPERA(  46),IX(  46),IY(  46)/'DRAW',   5,  -3/
      DATA IOPERA(  47),IX(  47),IY(  47)/'MOVE',   8,  -1/
      DATA IOPERA(  48),IX(  48),IY(  48)/'DRAW',   7,  -3/
      DATA IOPERA(  49),IX(  49),IY(  49)/'MOVE',   9,  -1/
      DATA IOPERA(  50),IX(  50),IY(  50)/'DRAW',   7,  -2/
C
      DATA IXMIND(   7)/ -11/
      DATA IXMAXD(   7)/  12/
      DATA IXDELD(   7)/  23/
      DATA ISTARD(   7)/   1/
      DATA NUMCOO(   7)/  50/
C
C     DEFINE CHARACTER   3008--UPPER CASE H
C
      DATA IOPERA(  51),IX(  51),IY(  51)/'MOVE',  -7,  12/
      DATA IOPERA(  52),IX(  52),IY(  52)/'DRAW',  -7,  -9/
      DATA IOPERA(  53),IX(  53),IY(  53)/'MOVE',  -6,  11/
      DATA IOPERA(  54),IX(  54),IY(  54)/'DRAW',  -6,  -8/
      DATA IOPERA(  55),IX(  55),IY(  55)/'MOVE',  -5,  12/
      DATA IOPERA(  56),IX(  56),IY(  56)/'DRAW',  -5,  -9/
      DATA IOPERA(  57),IX(  57),IY(  57)/'MOVE',   5,  12/
      DATA IOPERA(  58),IX(  58),IY(  58)/'DRAW',   5,  -9/
      DATA IOPERA(  59),IX(  59),IY(  59)/'MOVE',   6,  11/
      DATA IOPERA(  60),IX(  60),IY(  60)/'DRAW',   6,  -8/
      DATA IOPERA(  61),IX(  61),IY(  61)/'MOVE',   7,  12/
      DATA IOPERA(  62),IX(  62),IY(  62)/'DRAW',   7,  -9/
      DATA IOPERA(  63),IX(  63),IY(  63)/'MOVE', -10,  12/
      DATA IOPERA(  64),IX(  64),IY(  64)/'DRAW',  -2,  12/
      DATA IOPERA(  65),IX(  65),IY(  65)/'MOVE',   2,  12/
      DATA IOPERA(  66),IX(  66),IY(  66)/'DRAW',  10,  12/
      DATA IOPERA(  67),IX(  67),IY(  67)/'MOVE',  -5,   2/
      DATA IOPERA(  68),IX(  68),IY(  68)/'DRAW',   5,   2/
      DATA IOPERA(  69),IX(  69),IY(  69)/'MOVE', -10,  -9/
      DATA IOPERA(  70),IX(  70),IY(  70)/'DRAW',  -2,  -9/
      DATA IOPERA(  71),IX(  71),IY(  71)/'MOVE',   2,  -9/
      DATA IOPERA(  72),IX(  72),IY(  72)/'DRAW',  10,  -9/
      DATA IOPERA(  73),IX(  73),IY(  73)/'MOVE',  -9,  12/
      DATA IOPERA(  74),IX(  74),IY(  74)/'DRAW',  -7,  11/
      DATA IOPERA(  75),IX(  75),IY(  75)/'MOVE',  -8,  12/
      DATA IOPERA(  76),IX(  76),IY(  76)/'DRAW',  -7,  10/
      DATA IOPERA(  77),IX(  77),IY(  77)/'MOVE',  -4,  12/
      DATA IOPERA(  78),IX(  78),IY(  78)/'DRAW',  -5,  10/
      DATA IOPERA(  79),IX(  79),IY(  79)/'MOVE',  -3,  12/
      DATA IOPERA(  80),IX(  80),IY(  80)/'DRAW',  -5,  11/
      DATA IOPERA(  81),IX(  81),IY(  81)/'MOVE',   3,  12/
      DATA IOPERA(  82),IX(  82),IY(  82)/'DRAW',   5,  11/
      DATA IOPERA(  83),IX(  83),IY(  83)/'MOVE',   4,  12/
      DATA IOPERA(  84),IX(  84),IY(  84)/'DRAW',   5,  10/
      DATA IOPERA(  85),IX(  85),IY(  85)/'MOVE',   8,  12/
      DATA IOPERA(  86),IX(  86),IY(  86)/'DRAW',   7,  10/
      DATA IOPERA(  87),IX(  87),IY(  87)/'MOVE',   9,  12/
      DATA IOPERA(  88),IX(  88),IY(  88)/'DRAW',   7,  11/
      DATA IOPERA(  89),IX(  89),IY(  89)/'MOVE',  -7,  -8/
      DATA IOPERA(  90),IX(  90),IY(  90)/'DRAW',  -9,  -9/
      DATA IOPERA(  91),IX(  91),IY(  91)/'MOVE',  -7,  -7/
      DATA IOPERA(  92),IX(  92),IY(  92)/'DRAW',  -8,  -9/
      DATA IOPERA(  93),IX(  93),IY(  93)/'MOVE',  -5,  -7/
      DATA IOPERA(  94),IX(  94),IY(  94)/'DRAW',  -4,  -9/
      DATA IOPERA(  95),IX(  95),IY(  95)/'MOVE',  -5,  -8/
      DATA IOPERA(  96),IX(  96),IY(  96)/'DRAW',  -3,  -9/
      DATA IOPERA(  97),IX(  97),IY(  97)/'MOVE',   5,  -8/
      DATA IOPERA(  98),IX(  98),IY(  98)/'DRAW',   3,  -9/
      DATA IOPERA(  99),IX(  99),IY(  99)/'MOVE',   5,  -7/
      DATA IOPERA( 100),IX( 100),IY( 100)/'DRAW',   4,  -9/
      DATA IOPERA( 101),IX( 101),IY( 101)/'MOVE',   7,  -7/
      DATA IOPERA( 102),IX( 102),IY( 102)/'DRAW',   8,  -9/
      DATA IOPERA( 103),IX( 103),IY( 103)/'MOVE',   7,  -8/
      DATA IOPERA( 104),IX( 104),IY( 104)/'DRAW',   9,  -9/
C
      DATA IXMIND(   8)/ -12/
      DATA IXMAXD(   8)/  12/
      DATA IXDELD(   8)/  24/
      DATA ISTARD(   8)/  51/
      DATA NUMCOO(   8)/  54/
C
C     DEFINE CHARACTER   3009--UPPER CASE I
C
      DATA IOPERA( 105),IX( 105),IY( 105)/'MOVE',  -1,  12/
      DATA IOPERA( 106),IX( 106),IY( 106)/'DRAW',  -1,  -9/
      DATA IOPERA( 107),IX( 107),IY( 107)/'MOVE',   0,  11/
      DATA IOPERA( 108),IX( 108),IY( 108)/'DRAW',   0,  -8/
      DATA IOPERA( 109),IX( 109),IY( 109)/'MOVE',   1,  12/
      DATA IOPERA( 110),IX( 110),IY( 110)/'DRAW',   1,  -9/
      DATA IOPERA( 111),IX( 111),IY( 111)/'MOVE',  -4,  12/
      DATA IOPERA( 112),IX( 112),IY( 112)/'DRAW',   4,  12/
      DATA IOPERA( 113),IX( 113),IY( 113)/'MOVE',  -4,  -9/
      DATA IOPERA( 114),IX( 114),IY( 114)/'DRAW',   4,  -9/
      DATA IOPERA( 115),IX( 115),IY( 115)/'MOVE',  -3,  12/
      DATA IOPERA( 116),IX( 116),IY( 116)/'DRAW',  -1,  11/
      DATA IOPERA( 117),IX( 117),IY( 117)/'MOVE',  -2,  12/
      DATA IOPERA( 118),IX( 118),IY( 118)/'DRAW',  -1,  10/
      DATA IOPERA( 119),IX( 119),IY( 119)/'MOVE',   2,  12/
      DATA IOPERA( 120),IX( 120),IY( 120)/'DRAW',   1,  10/
      DATA IOPERA( 121),IX( 121),IY( 121)/'MOVE',   3,  12/
      DATA IOPERA( 122),IX( 122),IY( 122)/'DRAW',   1,  11/
      DATA IOPERA( 123),IX( 123),IY( 123)/'MOVE',  -1,  -8/
      DATA IOPERA( 124),IX( 124),IY( 124)/'DRAW',  -3,  -9/
      DATA IOPERA( 125),IX( 125),IY( 125)/'MOVE',  -1,  -7/
      DATA IOPERA( 126),IX( 126),IY( 126)/'DRAW',  -2,  -9/
      DATA IOPERA( 127),IX( 127),IY( 127)/'MOVE',   1,  -7/
      DATA IOPERA( 128),IX( 128),IY( 128)/'DRAW',   2,  -9/
      DATA IOPERA( 129),IX( 129),IY( 129)/'MOVE',   1,  -8/
      DATA IOPERA( 130),IX( 130),IY( 130)/'DRAW',   3,  -9/
C
      DATA IXMIND(   9)/  -6/
      DATA IXMAXD(   9)/   6/
      DATA IXDELD(   9)/  12/
      DATA ISTARD(   9)/ 105/
      DATA NUMCOO(   9)/  26/
C
C     DEFINE CHARACTER   3010--UPPER CASE J
C
      DATA IOPERA( 131),IX( 131),IY( 131)/'MOVE',   1,  12/
      DATA IOPERA( 132),IX( 132),IY( 132)/'DRAW',   1,  -5/
      DATA IOPERA( 133),IX( 133),IY( 133)/'DRAW',   0,  -8/
      DATA IOPERA( 134),IX( 134),IY( 134)/'DRAW',  -1,  -9/
      DATA IOPERA( 135),IX( 135),IY( 135)/'MOVE',   2,  11/
      DATA IOPERA( 136),IX( 136),IY( 136)/'DRAW',   2,  -5/
      DATA IOPERA( 137),IX( 137),IY( 137)/'DRAW',   1,  -8/
      DATA IOPERA( 138),IX( 138),IY( 138)/'MOVE',   3,  12/
      DATA IOPERA( 139),IX( 139),IY( 139)/'DRAW',   3,  -5/
      DATA IOPERA( 140),IX( 140),IY( 140)/'DRAW',   2,  -8/
      DATA IOPERA( 141),IX( 141),IY( 141)/'DRAW',  -1,  -9/
      DATA IOPERA( 142),IX( 142),IY( 142)/'DRAW',  -3,  -9/
      DATA IOPERA( 143),IX( 143),IY( 143)/'DRAW',  -5,  -8/
      DATA IOPERA( 144),IX( 144),IY( 144)/'DRAW',  -6,  -6/
      DATA IOPERA( 145),IX( 145),IY( 145)/'DRAW',  -6,  -4/
      DATA IOPERA( 146),IX( 146),IY( 146)/'DRAW',  -5,  -3/
      DATA IOPERA( 147),IX( 147),IY( 147)/'DRAW',  -4,  -3/
      DATA IOPERA( 148),IX( 148),IY( 148)/'DRAW',  -3,  -4/
      DATA IOPERA( 149),IX( 149),IY( 149)/'DRAW',  -3,  -5/
      DATA IOPERA( 150),IX( 150),IY( 150)/'DRAW',  -4,  -6/
      DATA IOPERA( 151),IX( 151),IY( 151)/'DRAW',  -5,  -6/
      DATA IOPERA( 152),IX( 152),IY( 152)/'MOVE',  -5,  -4/
      DATA IOPERA( 153),IX( 153),IY( 153)/'DRAW',  -5,  -5/
      DATA IOPERA( 154),IX( 154),IY( 154)/'DRAW',  -4,  -5/
      DATA IOPERA( 155),IX( 155),IY( 155)/'DRAW',  -4,  -4/
      DATA IOPERA( 156),IX( 156),IY( 156)/'DRAW',  -5,  -4/
      DATA IOPERA( 157),IX( 157),IY( 157)/'MOVE',  -2,  12/
      DATA IOPERA( 158),IX( 158),IY( 158)/'DRAW',   6,  12/
      DATA IOPERA( 159),IX( 159),IY( 159)/'MOVE',  -1,  12/
      DATA IOPERA( 160),IX( 160),IY( 160)/'DRAW',   1,  11/
      DATA IOPERA( 161),IX( 161),IY( 161)/'MOVE',   0,  12/
      DATA IOPERA( 162),IX( 162),IY( 162)/'DRAW',   1,  10/
      DATA IOPERA( 163),IX( 163),IY( 163)/'MOVE',   4,  12/
      DATA IOPERA( 164),IX( 164),IY( 164)/'DRAW',   3,  10/
      DATA IOPERA( 165),IX( 165),IY( 165)/'MOVE',   5,  12/
      DATA IOPERA( 166),IX( 166),IY( 166)/'DRAW',   3,  11/
C
      DATA IXMIND(  10)/  -8/
      DATA IXMAXD(  10)/   8/
      DATA IXDELD(  10)/  16/
      DATA ISTARD(  10)/ 131/
      DATA NUMCOO(  10)/  36/
C
C     DEFINE CHARACTER   3011--UPPER CASE K
C
      DATA IOPERA( 167),IX( 167),IY( 167)/'MOVE',  -7,  12/
      DATA IOPERA( 168),IX( 168),IY( 168)/'DRAW',  -7,  -9/
      DATA IOPERA( 169),IX( 169),IY( 169)/'MOVE',  -6,  11/
      DATA IOPERA( 170),IX( 170),IY( 170)/'DRAW',  -6,  -8/
      DATA IOPERA( 171),IX( 171),IY( 171)/'MOVE',  -5,  12/
      DATA IOPERA( 172),IX( 172),IY( 172)/'DRAW',  -5,  -9/
      DATA IOPERA( 173),IX( 173),IY( 173)/'MOVE',   6,  11/
      DATA IOPERA( 174),IX( 174),IY( 174)/'DRAW',  -5,   0/
      DATA IOPERA( 175),IX( 175),IY( 175)/'MOVE',  -2,   2/
      DATA IOPERA( 176),IX( 176),IY( 176)/'DRAW',   5,  -9/
      DATA IOPERA( 177),IX( 177),IY( 177)/'MOVE',  -1,   2/
      DATA IOPERA( 178),IX( 178),IY( 178)/'DRAW',   6,  -9/
      DATA IOPERA( 179),IX( 179),IY( 179)/'MOVE',  -1,   4/
      DATA IOPERA( 180),IX( 180),IY( 180)/'DRAW',   7,  -9/
      DATA IOPERA( 181),IX( 181),IY( 181)/'MOVE', -10,  12/
      DATA IOPERA( 182),IX( 182),IY( 182)/'DRAW',  -2,  12/
      DATA IOPERA( 183),IX( 183),IY( 183)/'MOVE',   3,  12/
      DATA IOPERA( 184),IX( 184),IY( 184)/'DRAW',   9,  12/
      DATA IOPERA( 185),IX( 185),IY( 185)/'MOVE', -10,  -9/
      DATA IOPERA( 186),IX( 186),IY( 186)/'DRAW',  -2,  -9/
      DATA IOPERA( 187),IX( 187),IY( 187)/'MOVE',   2,  -9/
      DATA IOPERA( 188),IX( 188),IY( 188)/'DRAW',   9,  -9/
      DATA IOPERA( 189),IX( 189),IY( 189)/'MOVE',  -9,  12/
      DATA IOPERA( 190),IX( 190),IY( 190)/'DRAW',  -7,  11/
      DATA IOPERA( 191),IX( 191),IY( 191)/'MOVE',  -8,  12/
      DATA IOPERA( 192),IX( 192),IY( 192)/'DRAW',  -7,  10/
      DATA IOPERA( 193),IX( 193),IY( 193)/'MOVE',  -4,  12/
      DATA IOPERA( 194),IX( 194),IY( 194)/'DRAW',  -5,  10/
      DATA IOPERA( 195),IX( 195),IY( 195)/'MOVE',  -3,  12/
      DATA IOPERA( 196),IX( 196),IY( 196)/'DRAW',  -5,  11/
      DATA IOPERA( 197),IX( 197),IY( 197)/'MOVE',   5,  12/
      DATA IOPERA( 198),IX( 198),IY( 198)/'DRAW',   6,  11/
      DATA IOPERA( 199),IX( 199),IY( 199)/'MOVE',   8,  12/
      DATA IOPERA( 200),IX( 200),IY( 200)/'DRAW',   6,  11/
      DATA IOPERA( 201),IX( 201),IY( 201)/'MOVE',  -7,  -8/
      DATA IOPERA( 202),IX( 202),IY( 202)/'DRAW',  -9,  -9/
      DATA IOPERA( 203),IX( 203),IY( 203)/'MOVE',  -7,  -7/
      DATA IOPERA( 204),IX( 204),IY( 204)/'DRAW',  -8,  -9/
      DATA IOPERA( 205),IX( 205),IY( 205)/'MOVE',  -5,  -7/
      DATA IOPERA( 206),IX( 206),IY( 206)/'DRAW',  -4,  -9/
      DATA IOPERA( 207),IX( 207),IY( 207)/'MOVE',  -5,  -8/
      DATA IOPERA( 208),IX( 208),IY( 208)/'DRAW',  -3,  -9/
      DATA IOPERA( 209),IX( 209),IY( 209)/'MOVE',   5,  -7/
      DATA IOPERA( 210),IX( 210),IY( 210)/'DRAW',   3,  -9/
      DATA IOPERA( 211),IX( 211),IY( 211)/'MOVE',   5,  -7/
      DATA IOPERA( 212),IX( 212),IY( 212)/'DRAW',   8,  -9/
C
      DATA IXMIND(  11)/ -12/
      DATA IXMAXD(  11)/  10/
      DATA IXDELD(  11)/  22/
      DATA ISTARD(  11)/ 167/
      DATA NUMCOO(  11)/  46/
C
C     DEFINE CHARACTER   3012--UPPER CASE L
C
      DATA IOPERA( 213),IX( 213),IY( 213)/'MOVE',  -4,  12/
      DATA IOPERA( 214),IX( 214),IY( 214)/'DRAW',  -4,  -9/
      DATA IOPERA( 215),IX( 215),IY( 215)/'MOVE',  -3,  11/
      DATA IOPERA( 216),IX( 216),IY( 216)/'DRAW',  -3,  -8/
      DATA IOPERA( 217),IX( 217),IY( 217)/'MOVE',  -2,  12/
      DATA IOPERA( 218),IX( 218),IY( 218)/'DRAW',  -2,  -9/
      DATA IOPERA( 219),IX( 219),IY( 219)/'MOVE',  -7,  12/
      DATA IOPERA( 220),IX( 220),IY( 220)/'DRAW',   1,  12/
      DATA IOPERA( 221),IX( 221),IY( 221)/'MOVE',  -7,  -9/
      DATA IOPERA( 222),IX( 222),IY( 222)/'DRAW',   8,  -9/
      DATA IOPERA( 223),IX( 223),IY( 223)/'DRAW',   8,  -3/
      DATA IOPERA( 224),IX( 224),IY( 224)/'MOVE',  -6,  12/
      DATA IOPERA( 225),IX( 225),IY( 225)/'DRAW',  -4,  11/
      DATA IOPERA( 226),IX( 226),IY( 226)/'MOVE',  -5,  12/
      DATA IOPERA( 227),IX( 227),IY( 227)/'DRAW',  -4,  10/
      DATA IOPERA( 228),IX( 228),IY( 228)/'MOVE',  -1,  12/
      DATA IOPERA( 229),IX( 229),IY( 229)/'DRAW',  -2,  10/
      DATA IOPERA( 230),IX( 230),IY( 230)/'MOVE',   0,  12/
      DATA IOPERA( 231),IX( 231),IY( 231)/'DRAW',  -2,  11/
      DATA IOPERA( 232),IX( 232),IY( 232)/'MOVE',  -4,  -8/
      DATA IOPERA( 233),IX( 233),IY( 233)/'DRAW',  -6,  -9/
      DATA IOPERA( 234),IX( 234),IY( 234)/'MOVE',  -4,  -7/
      DATA IOPERA( 235),IX( 235),IY( 235)/'DRAW',  -5,  -9/
      DATA IOPERA( 236),IX( 236),IY( 236)/'MOVE',  -2,  -7/
      DATA IOPERA( 237),IX( 237),IY( 237)/'DRAW',  -1,  -9/
      DATA IOPERA( 238),IX( 238),IY( 238)/'MOVE',  -2,  -8/
      DATA IOPERA( 239),IX( 239),IY( 239)/'DRAW',   0,  -9/
      DATA IOPERA( 240),IX( 240),IY( 240)/'MOVE',   3,  -9/
      DATA IOPERA( 241),IX( 241),IY( 241)/'DRAW',   8,  -8/
      DATA IOPERA( 242),IX( 242),IY( 242)/'MOVE',   5,  -9/
      DATA IOPERA( 243),IX( 243),IY( 243)/'DRAW',   8,  -7/
      DATA IOPERA( 244),IX( 244),IY( 244)/'MOVE',   6,  -9/
      DATA IOPERA( 245),IX( 245),IY( 245)/'DRAW',   8,  -6/
      DATA IOPERA( 246),IX( 246),IY( 246)/'MOVE',   7,  -9/
      DATA IOPERA( 247),IX( 247),IY( 247)/'DRAW',   8,  -3/
C
      DATA IXMIND(  12)/  -9/
      DATA IXMAXD(  12)/   9/
      DATA IXDELD(  12)/  18/
      DATA ISTARD(  12)/ 213/
      DATA NUMCOO(  12)/  35/
C
C     DEFINE CHARACTER   3013--UPPER CASE M
C
      DATA IOPERA( 248),IX( 248),IY( 248)/'MOVE',  -8,  12/
      DATA IOPERA( 249),IX( 249),IY( 249)/'DRAW',  -8,  -8/
      DATA IOPERA( 250),IX( 250),IY( 250)/'MOVE',  -8,  12/
      DATA IOPERA( 251),IX( 251),IY( 251)/'DRAW',  -1,  -9/
      DATA IOPERA( 252),IX( 252),IY( 252)/'MOVE',  -7,  12/
      DATA IOPERA( 253),IX( 253),IY( 253)/'DRAW',  -1,  -6/
      DATA IOPERA( 254),IX( 254),IY( 254)/'MOVE',  -6,  12/
      DATA IOPERA( 255),IX( 255),IY( 255)/'DRAW',   0,  -6/
      DATA IOPERA( 256),IX( 256),IY( 256)/'MOVE',   6,  12/
      DATA IOPERA( 257),IX( 257),IY( 257)/'DRAW',  -1,  -9/
      DATA IOPERA( 258),IX( 258),IY( 258)/'MOVE',   6,  12/
      DATA IOPERA( 259),IX( 259),IY( 259)/'DRAW',   6,  -9/
      DATA IOPERA( 260),IX( 260),IY( 260)/'MOVE',   7,  11/
      DATA IOPERA( 261),IX( 261),IY( 261)/'DRAW',   7,  -8/
      DATA IOPERA( 262),IX( 262),IY( 262)/'MOVE',   8,  12/
      DATA IOPERA( 263),IX( 263),IY( 263)/'DRAW',   8,  -9/
      DATA IOPERA( 264),IX( 264),IY( 264)/'MOVE', -11,  12/
      DATA IOPERA( 265),IX( 265),IY( 265)/'DRAW',  -6,  12/
      DATA IOPERA( 266),IX( 266),IY( 266)/'MOVE',   6,  12/
      DATA IOPERA( 267),IX( 267),IY( 267)/'DRAW',  11,  12/
      DATA IOPERA( 268),IX( 268),IY( 268)/'MOVE', -11,  -9/
      DATA IOPERA( 269),IX( 269),IY( 269)/'DRAW',  -5,  -9/
      DATA IOPERA( 270),IX( 270),IY( 270)/'MOVE',   3,  -9/
      DATA IOPERA( 271),IX( 271),IY( 271)/'DRAW',  11,  -9/
      DATA IOPERA( 272),IX( 272),IY( 272)/'MOVE', -10,  12/
      DATA IOPERA( 273),IX( 273),IY( 273)/'DRAW',  -8,  11/
      DATA IOPERA( 274),IX( 274),IY( 274)/'MOVE',   9,  12/
      DATA IOPERA( 275),IX( 275),IY( 275)/'DRAW',   8,  10/
      DATA IOPERA( 276),IX( 276),IY( 276)/'MOVE',  10,  12/
      DATA IOPERA( 277),IX( 277),IY( 277)/'DRAW',   8,  11/
      DATA IOPERA( 278),IX( 278),IY( 278)/'MOVE',  -8,  -8/
      DATA IOPERA( 279),IX( 279),IY( 279)/'DRAW', -10,  -9/
      DATA IOPERA( 280),IX( 280),IY( 280)/'MOVE',  -8,  -8/
      DATA IOPERA( 281),IX( 281),IY( 281)/'DRAW',  -6,  -9/
      DATA IOPERA( 282),IX( 282),IY( 282)/'MOVE',   6,  -8/
      DATA IOPERA( 283),IX( 283),IY( 283)/'DRAW',   4,  -9/
      DATA IOPERA( 284),IX( 284),IY( 284)/'MOVE',   6,  -7/
      DATA IOPERA( 285),IX( 285),IY( 285)/'DRAW',   5,  -9/
      DATA IOPERA( 286),IX( 286),IY( 286)/'MOVE',   8,  -7/
      DATA IOPERA( 287),IX( 287),IY( 287)/'DRAW',   9,  -9/
      DATA IOPERA( 288),IX( 288),IY( 288)/'MOVE',   8,  -8/
      DATA IOPERA( 289),IX( 289),IY( 289)/'DRAW',  10,  -9/
C
      DATA IXMIND(  13)/ -13/
      DATA IXMAXD(  13)/  13/
      DATA IXDELD(  13)/  26/
      DATA ISTARD(  13)/ 248/
      DATA NUMCOO(  13)/  42/
C
C-----START POINT-----------------------------------------------------
C
      IFOUND='YES'
      IERROR='NO'
C
      NUMCO=1
      ISTART=1
      ISTOP=1
      NC=1
C
C               ******************************************
C               **  TREAT THE ROMAN SIMPLEX UPPER CASE  **
C               **  HERSHEY CHARACTER SET CASE          **
C               ******************************************
C
C
      IF(IBUGD2.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DRTU2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ICHARN
   52 FORMAT('ICHARN = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR
   59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               **************************************
C               **  STEP 2--                        **
C               **  EXTRACT THE COORDINATES         **
C               **  FOR THIS PARTICULAR CHARACTER.  **
C               **************************************
C
 1000 CONTINUE
      ISTART=ISTARD(ICHARN)
      NC=NUMCOO(ICHARN)
      ISTOP=ISTART+NC-1
      J=0
      DO1100I=ISTART,ISTOP
      J=J+1
      IOP(J)=IOPERA(I)
      X(J)=IX(I)
      Y(J)=IY(I)
 1100 CONTINUE
      NUMCO=J
      IXMINS=IXMIND(ICHARN)
      IXMAXS=IXMAXD(ICHARN)
      IXDELS=IXDELD(ICHARN)
C
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGD2.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DRTU2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR
 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)ICHARN
 9013 FORMAT('ICHARN = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO
 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8)
      CALL DPWRST('XXX','BUG ')
      IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019
      DO9015I=1,NUMCO
      WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I)
 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9019 CONTINUE
      WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS
 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DRTU3(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
     1IBUGD2,IFOUND,IERROR)
C
C     PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES
C              FOR ROMAN TRIPLEX UPPER CASE (PART 3).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/4
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH     1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MARCH     1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IOP
      CHARACTER*4 IBUGD2
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IOPERA
C
C---------------------------------------------------------------------
C
      DIMENSION IOP(*)
      DIMENSION X(*)
      DIMENSION Y(*)
C
      DIMENSION IOPERA(300)
      DIMENSION IX(300)
      DIMENSION IY(300)
C
      DIMENSION IXMIND(30)
      DIMENSION IXMAXD(30)
      DIMENSION IXDELD(30)
      DIMENSION ISTARD(30)
      DIMENSION NUMCOO(30)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C     DEFINE CHARACTER   3014--UPPER CASE N
C
      DATA IOPERA(   1),IX(   1),IY(   1)/'MOVE',  -7,  12/
      DATA IOPERA(   2),IX(   2),IY(   2)/'DRAW',  -7,  -8/
      DATA IOPERA(   3),IX(   3),IY(   3)/'MOVE',  -7,  12/
      DATA IOPERA(   4),IX(   4),IY(   4)/'DRAW',   7,  -9/
      DATA IOPERA(   5),IX(   5),IY(   5)/'MOVE',  -6,  12/
      DATA IOPERA(   6),IX(   6),IY(   6)/'DRAW',   6,  -6/
      DATA IOPERA(   7),IX(   7),IY(   7)/'MOVE',  -5,  12/
      DATA IOPERA(   8),IX(   8),IY(   8)/'DRAW',   7,  -6/
      DATA IOPERA(   9),IX(   9),IY(   9)/'MOVE',   7,  11/
      DATA IOPERA(  10),IX(  10),IY(  10)/'DRAW',   7,  -9/
      DATA IOPERA(  11),IX(  11),IY(  11)/'MOVE', -10,  12/
      DATA IOPERA(  12),IX(  12),IY(  12)/'DRAW',  -5,  12/
      DATA IOPERA(  13),IX(  13),IY(  13)/'MOVE',   4,  12/
      DATA IOPERA(  14),IX(  14),IY(  14)/'DRAW',  10,  12/
      DATA IOPERA(  15),IX(  15),IY(  15)/'MOVE', -10,  -9/
      DATA IOPERA(  16),IX(  16),IY(  16)/'DRAW',  -4,  -9/
      DATA IOPERA(  17),IX(  17),IY(  17)/'MOVE',  -9,  12/
      DATA IOPERA(  18),IX(  18),IY(  18)/'DRAW',  -7,  11/
      DATA IOPERA(  19),IX(  19),IY(  19)/'MOVE',   5,  12/
      DATA IOPERA(  20),IX(  20),IY(  20)/'DRAW',   7,  11/
      DATA IOPERA(  21),IX(  21),IY(  21)/'MOVE',   9,  12/
      DATA IOPERA(  22),IX(  22),IY(  22)/'DRAW',   7,  11/
      DATA IOPERA(  23),IX(  23),IY(  23)/'MOVE',  -7,  -8/
      DATA IOPERA(  24),IX(  24),IY(  24)/'DRAW',  -9,  -9/
      DATA IOPERA(  25),IX(  25),IY(  25)/'MOVE',  -7,  -8/
      DATA IOPERA(  26),IX(  26),IY(  26)/'DRAW',  -5,  -9/
C
      DATA IXMIND(  14)/ -12/
      DATA IXMAXD(  14)/  12/
      DATA IXDELD(  14)/  24/
      DATA ISTARD(  14)/   1/
      DATA NUMCOO(  14)/  26/
C
C     DEFINE CHARACTER   3015--UPPER CASE O
C
      DATA IOPERA(  27),IX(  27),IY(  27)/'MOVE',  -1,  12/
      DATA IOPERA(  28),IX(  28),IY(  28)/'DRAW',  -4,  11/
      DATA IOPERA(  29),IX(  29),IY(  29)/'DRAW',  -6,   9/
      DATA IOPERA(  30),IX(  30),IY(  30)/'DRAW',  -7,   7/
      DATA IOPERA(  31),IX(  31),IY(  31)/'DRAW',  -8,   3/
      DATA IOPERA(  32),IX(  32),IY(  32)/'DRAW',  -8,   0/
      DATA IOPERA(  33),IX(  33),IY(  33)/'DRAW',  -7,  -4/
      DATA IOPERA(  34),IX(  34),IY(  34)/'DRAW',  -6,  -6/
      DATA IOPERA(  35),IX(  35),IY(  35)/'DRAW',  -4,  -8/
      DATA IOPERA(  36),IX(  36),IY(  36)/'DRAW',  -1,  -9/
      DATA IOPERA(  37),IX(  37),IY(  37)/'DRAW',   1,  -9/
      DATA IOPERA(  38),IX(  38),IY(  38)/'DRAW',   4,  -8/
      DATA IOPERA(  39),IX(  39),IY(  39)/'DRAW',   6,  -6/
      DATA IOPERA(  40),IX(  40),IY(  40)/'DRAW',   7,  -4/
      DATA IOPERA(  41),IX(  41),IY(  41)/'DRAW',   8,   0/
      DATA IOPERA(  42),IX(  42),IY(  42)/'DRAW',   8,   3/
      DATA IOPERA(  43),IX(  43),IY(  43)/'DRAW',   7,   7/
      DATA IOPERA(  44),IX(  44),IY(  44)/'DRAW',   6,   9/
      DATA IOPERA(  45),IX(  45),IY(  45)/'DRAW',   4,  11/
      DATA IOPERA(  46),IX(  46),IY(  46)/'DRAW',   1,  12/
      DATA IOPERA(  47),IX(  47),IY(  47)/'DRAW',  -1,  12/
      DATA IOPERA(  48),IX(  48),IY(  48)/'MOVE',  -5,   9/
      DATA IOPERA(  49),IX(  49),IY(  49)/'DRAW',  -6,   7/
      DATA IOPERA(  50),IX(  50),IY(  50)/'DRAW',  -7,   4/
      DATA IOPERA(  51),IX(  51),IY(  51)/'DRAW',  -7,  -1/
      DATA IOPERA(  52),IX(  52),IY(  52)/'DRAW',  -6,  -4/
      DATA IOPERA(  53),IX(  53),IY(  53)/'DRAW',  -5,  -6/
      DATA IOPERA(  54),IX(  54),IY(  54)/'MOVE',   5,  -6/
      DATA IOPERA(  55),IX(  55),IY(  55)/'DRAW',   6,  -4/
      DATA IOPERA(  56),IX(  56),IY(  56)/'DRAW',   7,  -1/
      DATA IOPERA(  57),IX(  57),IY(  57)/'DRAW',   7,   4/
      DATA IOPERA(  58),IX(  58),IY(  58)/'DRAW',   6,   7/
      DATA IOPERA(  59),IX(  59),IY(  59)/'DRAW',   5,   9/
      DATA IOPERA(  60),IX(  60),IY(  60)/'MOVE',  -1,  12/
      DATA IOPERA(  61),IX(  61),IY(  61)/'DRAW',  -3,  11/
      DATA IOPERA(  62),IX(  62),IY(  62)/'DRAW',  -5,   8/
      DATA IOPERA(  63),IX(  63),IY(  63)/'DRAW',  -6,   4/
      DATA IOPERA(  64),IX(  64),IY(  64)/'DRAW',  -6,  -1/
      DATA IOPERA(  65),IX(  65),IY(  65)/'DRAW',  -5,  -5/
      DATA IOPERA(  66),IX(  66),IY(  66)/'DRAW',  -3,  -8/
      DATA IOPERA(  67),IX(  67),IY(  67)/'DRAW',  -1,  -9/
      DATA IOPERA(  68),IX(  68),IY(  68)/'MOVE',   1,  -9/
      DATA IOPERA(  69),IX(  69),IY(  69)/'DRAW',   3,  -8/
      DATA IOPERA(  70),IX(  70),IY(  70)/'DRAW',   5,  -5/
      DATA IOPERA(  71),IX(  71),IY(  71)/'DRAW',   6,  -1/
      DATA IOPERA(  72),IX(  72),IY(  72)/'DRAW',   6,   4/
      DATA IOPERA(  73),IX(  73),IY(  73)/'DRAW',   5,   8/
      DATA IOPERA(  74),IX(  74),IY(  74)/'DRAW',   3,  11/
      DATA IOPERA(  75),IX(  75),IY(  75)/'DRAW',   1,  12/
C
      DATA IXMIND(  15)/ -11/
      DATA IXMAXD(  15)/  11/
      DATA IXDELD(  15)/  22/
      DATA ISTARD(  15)/  27/
      DATA NUMCOO(  15)/  49/
C
C     DEFINE CHARACTER   3016--UPPER CASE P
C
      DATA IOPERA(  76),IX(  76),IY(  76)/'MOVE',  -6,  12/
      DATA IOPERA(  77),IX(  77),IY(  77)/'DRAW',  -6,  -9/
      DATA IOPERA(  78),IX(  78),IY(  78)/'MOVE',  -5,  11/
      DATA IOPERA(  79),IX(  79),IY(  79)/'DRAW',  -5,  -8/
      DATA IOPERA(  80),IX(  80),IY(  80)/'MOVE',  -4,  12/
      DATA IOPERA(  81),IX(  81),IY(  81)/'DRAW',  -4,  -9/
      DATA IOPERA(  82),IX(  82),IY(  82)/'MOVE',  -9,  12/
      DATA IOPERA(  83),IX(  83),IY(  83)/'DRAW',   3,  12/
      DATA IOPERA(  84),IX(  84),IY(  84)/'DRAW',   6,  11/
      DATA IOPERA(  85),IX(  85),IY(  85)/'DRAW',   7,  10/
      DATA IOPERA(  86),IX(  86),IY(  86)/'DRAW',   8,   8/
      DATA IOPERA(  87),IX(  87),IY(  87)/'DRAW',   8,   5/
      DATA IOPERA(  88),IX(  88),IY(  88)/'DRAW',   7,   3/
      DATA IOPERA(  89),IX(  89),IY(  89)/'DRAW',   6,   2/
      DATA IOPERA(  90),IX(  90),IY(  90)/'DRAW',   3,   1/
      DATA IOPERA(  91),IX(  91),IY(  91)/'DRAW',  -4,   1/
      DATA IOPERA(  92),IX(  92),IY(  92)/'MOVE',   6,  10/
      DATA IOPERA(  93),IX(  93),IY(  93)/'DRAW',   7,   8/
      DATA IOPERA(  94),IX(  94),IY(  94)/'DRAW',   7,   5/
      DATA IOPERA(  95),IX(  95),IY(  95)/'DRAW',   6,   3/
      DATA IOPERA(  96),IX(  96),IY(  96)/'MOVE',   3,  12/
      DATA IOPERA(  97),IX(  97),IY(  97)/'DRAW',   5,  11/
      DATA IOPERA(  98),IX(  98),IY(  98)/'DRAW',   6,   9/
      DATA IOPERA(  99),IX(  99),IY(  99)/'DRAW',   6,   4/
      DATA IOPERA( 100),IX( 100),IY( 100)/'DRAW',   5,   2/
      DATA IOPERA( 101),IX( 101),IY( 101)/'DRAW',   3,   1/
      DATA IOPERA( 102),IX( 102),IY( 102)/'MOVE',  -9,  -9/
      DATA IOPERA( 103),IX( 103),IY( 103)/'DRAW',  -1,  -9/
      DATA IOPERA( 104),IX( 104),IY( 104)/'MOVE',  -8,  12/
      DATA IOPERA( 105),IX( 105),IY( 105)/'DRAW',  -6,  11/
      DATA IOPERA( 106),IX( 106),IY( 106)/'MOVE',  -7,  12/
      DATA IOPERA( 107),IX( 107),IY( 107)/'DRAW',  -6,  10/
      DATA IOPERA( 108),IX( 108),IY( 108)/'MOVE',  -3,  12/
      DATA IOPERA( 109),IX( 109),IY( 109)/'DRAW',  -4,  10/
      DATA IOPERA( 110),IX( 110),IY( 110)/'MOVE',  -2,  12/
      DATA IOPERA( 111),IX( 111),IY( 111)/'DRAW',  -4,  11/
      DATA IOPERA( 112),IX( 112),IY( 112)/'MOVE',  -6,  -8/
      DATA IOPERA( 113),IX( 113),IY( 113)/'DRAW',  -8,  -9/
      DATA IOPERA( 114),IX( 114),IY( 114)/'MOVE',  -6,  -7/
      DATA IOPERA( 115),IX( 115),IY( 115)/'DRAW',  -7,  -9/
      DATA IOPERA( 116),IX( 116),IY( 116)/'MOVE',  -4,  -7/
      DATA IOPERA( 117),IX( 117),IY( 117)/'DRAW',  -3,  -9/
      DATA IOPERA( 118),IX( 118),IY( 118)/'MOVE',  -4,  -8/
      DATA IOPERA( 119),IX( 119),IY( 119)/'DRAW',  -2,  -9/
C
      DATA IXMIND(  16)/ -11/
      DATA IXMAXD(  16)/  11/
      DATA IXDELD(  16)/  22/
      DATA ISTARD(  16)/  76/
      DATA NUMCOO(  16)/  44/
C
C     DEFINE CHARACTER   3017--UPPER CASE Q
C
      DATA IOPERA( 120),IX( 120),IY( 120)/'MOVE',  -1,  12/
      DATA IOPERA( 121),IX( 121),IY( 121)/'DRAW',  -4,  11/
      DATA IOPERA( 122),IX( 122),IY( 122)/'DRAW',  -6,   9/
      DATA IOPERA( 123),IX( 123),IY( 123)/'DRAW',  -7,   7/
      DATA IOPERA( 124),IX( 124),IY( 124)/'DRAW',  -8,   3/
      DATA IOPERA( 125),IX( 125),IY( 125)/'DRAW',  -8,   0/
      DATA IOPERA( 126),IX( 126),IY( 126)/'DRAW',  -7,  -4/
      DATA IOPERA( 127),IX( 127),IY( 127)/'DRAW',  -6,  -6/
      DATA IOPERA( 128),IX( 128),IY( 128)/'DRAW',  -4,  -8/
      DATA IOPERA( 129),IX( 129),IY( 129)/'DRAW',  -1,  -9/
      DATA IOPERA( 130),IX( 130),IY( 130)/'DRAW',   1,  -9/
      DATA IOPERA( 131),IX( 131),IY( 131)/'DRAW',   4,  -8/
      DATA IOPERA( 132),IX( 132),IY( 132)/'DRAW',   6,  -6/
      DATA IOPERA( 133),IX( 133),IY( 133)/'DRAW',   7,  -4/
      DATA IOPERA( 134),IX( 134),IY( 134)/'DRAW',   8,   0/
      DATA IOPERA( 135),IX( 135),IY( 135)/'DRAW',   8,   3/
      DATA IOPERA( 136),IX( 136),IY( 136)/'DRAW',   7,   7/
      DATA IOPERA( 137),IX( 137),IY( 137)/'DRAW',   6,   9/
      DATA IOPERA( 138),IX( 138),IY( 138)/'DRAW',   4,  11/
      DATA IOPERA( 139),IX( 139),IY( 139)/'DRAW',   1,  12/
      DATA IOPERA( 140),IX( 140),IY( 140)/'DRAW',  -1,  12/
      DATA IOPERA( 141),IX( 141),IY( 141)/'MOVE',  -5,   9/
      DATA IOPERA( 142),IX( 142),IY( 142)/'DRAW',  -6,   7/
      DATA IOPERA( 143),IX( 143),IY( 143)/'DRAW',  -7,   4/
      DATA IOPERA( 144),IX( 144),IY( 144)/'DRAW',  -7,  -1/
      DATA IOPERA( 145),IX( 145),IY( 145)/'DRAW',  -6,  -4/
      DATA IOPERA( 146),IX( 146),IY( 146)/'DRAW',  -5,  -6/
      DATA IOPERA( 147),IX( 147),IY( 147)/'MOVE',   5,  -6/
      DATA IOPERA( 148),IX( 148),IY( 148)/'DRAW',   6,  -4/
      DATA IOPERA( 149),IX( 149),IY( 149)/'DRAW',   7,  -1/
      DATA IOPERA( 150),IX( 150),IY( 150)/'DRAW',   7,   4/
      DATA IOPERA( 151),IX( 151),IY( 151)/'DRAW',   6,   7/
      DATA IOPERA( 152),IX( 152),IY( 152)/'DRAW',   5,   9/
      DATA IOPERA( 153),IX( 153),IY( 153)/'MOVE',  -1,  12/
      DATA IOPERA( 154),IX( 154),IY( 154)/'DRAW',  -3,  11/
      DATA IOPERA( 155),IX( 155),IY( 155)/'DRAW',  -5,   8/
      DATA IOPERA( 156),IX( 156),IY( 156)/'DRAW',  -6,   4/
      DATA IOPERA( 157),IX( 157),IY( 157)/'DRAW',  -6,  -1/
      DATA IOPERA( 158),IX( 158),IY( 158)/'DRAW',  -5,  -5/
      DATA IOPERA( 159),IX( 159),IY( 159)/'DRAW',  -3,  -8/
      DATA IOPERA( 160),IX( 160),IY( 160)/'DRAW',  -1,  -9/
      DATA IOPERA( 161),IX( 161),IY( 161)/'MOVE',   1,  -9/
      DATA IOPERA( 162),IX( 162),IY( 162)/'DRAW',   3,  -8/
      DATA IOPERA( 163),IX( 163),IY( 163)/'DRAW',   5,  -5/
      DATA IOPERA( 164),IX( 164),IY( 164)/'DRAW',   6,  -1/
      DATA IOPERA( 165),IX( 165),IY( 165)/'DRAW',   6,   4/
      DATA IOPERA( 166),IX( 166),IY( 166)/'DRAW',   5,   8/
      DATA IOPERA( 167),IX( 167),IY( 167)/'DRAW',   3,  11/
      DATA IOPERA( 168),IX( 168),IY( 168)/'DRAW',   1,  12/
      DATA IOPERA( 169),IX( 169),IY( 169)/'MOVE',  -4,  -6/
      DATA IOPERA( 170),IX( 170),IY( 170)/'DRAW',  -3,  -4/
      DATA IOPERA( 171),IX( 171),IY( 171)/'DRAW',  -1,  -3/
      DATA IOPERA( 172),IX( 172),IY( 172)/'DRAW',   0,  -3/
      DATA IOPERA( 173),IX( 173),IY( 173)/'DRAW',   2,  -4/
      DATA IOPERA( 174),IX( 174),IY( 174)/'DRAW',   3,  -6/
      DATA IOPERA( 175),IX( 175),IY( 175)/'DRAW',   4, -12/
      DATA IOPERA( 176),IX( 176),IY( 176)/'DRAW',   5, -14/
      DATA IOPERA( 177),IX( 177),IY( 177)/'DRAW',   7, -14/
      DATA IOPERA( 178),IX( 178),IY( 178)/'DRAW',   8, -12/
      DATA IOPERA( 179),IX( 179),IY( 179)/'DRAW',   8, -10/
      DATA IOPERA( 180),IX( 180),IY( 180)/'MOVE',   4, -10/
      DATA IOPERA( 181),IX( 181),IY( 181)/'DRAW',   5, -12/
      DATA IOPERA( 182),IX( 182),IY( 182)/'DRAW',   6, -13/
      DATA IOPERA( 183),IX( 183),IY( 183)/'DRAW',   7, -13/
      DATA IOPERA( 184),IX( 184),IY( 184)/'MOVE',   3,  -6/
      DATA IOPERA( 185),IX( 185),IY( 185)/'DRAW',   5, -11/
      DATA IOPERA( 186),IX( 186),IY( 186)/'DRAW',   6, -12/
      DATA IOPERA( 187),IX( 187),IY( 187)/'DRAW',   7, -12/
      DATA IOPERA( 188),IX( 188),IY( 188)/'DRAW',   8, -11/
C
      DATA IXMIND(  17)/ -11/
      DATA IXMAXD(  17)/  11/
      DATA IXDELD(  17)/  22/
      DATA ISTARD(  17)/ 120/
      DATA NUMCOO(  17)/  69/
C
C     DEFINE CHARACTER   3018--UPPER CASE R
C
      DATA IOPERA( 189),IX( 189),IY( 189)/'MOVE',  -6,  12/
      DATA IOPERA( 190),IX( 190),IY( 190)/'DRAW',  -6,  -9/
      DATA IOPERA( 191),IX( 191),IY( 191)/'MOVE',  -5,  11/
      DATA IOPERA( 192),IX( 192),IY( 192)/'DRAW',  -5,  -8/
      DATA IOPERA( 193),IX( 193),IY( 193)/'MOVE',  -4,  12/
      DATA IOPERA( 194),IX( 194),IY( 194)/'DRAW',  -4,  -9/
      DATA IOPERA( 195),IX( 195),IY( 195)/'MOVE',  -9,  12/
      DATA IOPERA( 196),IX( 196),IY( 196)/'DRAW',   3,  12/
      DATA IOPERA( 197),IX( 197),IY( 197)/'DRAW',   6,  11/
      DATA IOPERA( 198),IX( 198),IY( 198)/'DRAW',   7,  10/
      DATA IOPERA( 199),IX( 199),IY( 199)/'DRAW',   8,   8/
      DATA IOPERA( 200),IX( 200),IY( 200)/'DRAW',   8,   6/
      DATA IOPERA( 201),IX( 201),IY( 201)/'DRAW',   7,   4/
      DATA IOPERA( 202),IX( 202),IY( 202)/'DRAW',   6,   3/
      DATA IOPERA( 203),IX( 203),IY( 203)/'DRAW',   3,   2/
      DATA IOPERA( 204),IX( 204),IY( 204)/'DRAW',  -4,   2/
      DATA IOPERA( 205),IX( 205),IY( 205)/'MOVE',   6,  10/
      DATA IOPERA( 206),IX( 206),IY( 206)/'DRAW',   7,   8/
      DATA IOPERA( 207),IX( 207),IY( 207)/'DRAW',   7,   6/
      DATA IOPERA( 208),IX( 208),IY( 208)/'DRAW',   6,   4/
      DATA IOPERA( 209),IX( 209),IY( 209)/'MOVE',   3,  12/
      DATA IOPERA( 210),IX( 210),IY( 210)/'DRAW',   5,  11/
      DATA IOPERA( 211),IX( 211),IY( 211)/'DRAW',   6,   9/
      DATA IOPERA( 212),IX( 212),IY( 212)/'DRAW',   6,   5/
      DATA IOPERA( 213),IX( 213),IY( 213)/'DRAW',   5,   3/
      DATA IOPERA( 214),IX( 214),IY( 214)/'DRAW',   3,   2/
      DATA IOPERA( 215),IX( 215),IY( 215)/'MOVE',   0,   2/
      DATA IOPERA( 216),IX( 216),IY( 216)/'DRAW',   2,   1/
      DATA IOPERA( 217),IX( 217),IY( 217)/'DRAW',   3,  -1/
      DATA IOPERA( 218),IX( 218),IY( 218)/'DRAW',   5,  -7/
      DATA IOPERA( 219),IX( 219),IY( 219)/'DRAW',   6,  -9/
      DATA IOPERA( 220),IX( 220),IY( 220)/'DRAW',   8,  -9/
      DATA IOPERA( 221),IX( 221),IY( 221)/'DRAW',   9,  -7/
      DATA IOPERA( 222),IX( 222),IY( 222)/'DRAW',   9,  -5/
      DATA IOPERA( 223),IX( 223),IY( 223)/'MOVE',   5,  -5/
      DATA IOPERA( 224),IX( 224),IY( 224)/'DRAW',   6,  -7/
      DATA IOPERA( 225),IX( 225),IY( 225)/'DRAW',   7,  -8/
      DATA IOPERA( 226),IX( 226),IY( 226)/'DRAW',   8,  -8/
      DATA IOPERA( 227),IX( 227),IY( 227)/'MOVE',   2,   1/
      DATA IOPERA( 228),IX( 228),IY( 228)/'DRAW',   3,   0/
      DATA IOPERA( 229),IX( 229),IY( 229)/'DRAW',   6,  -6/
      DATA IOPERA( 230),IX( 230),IY( 230)/'DRAW',   7,  -7/
      DATA IOPERA( 231),IX( 231),IY( 231)/'DRAW',   8,  -7/
      DATA IOPERA( 232),IX( 232),IY( 232)/'DRAW',   9,  -6/
      DATA IOPERA( 233),IX( 233),IY( 233)/'MOVE',  -9,  -9/
      DATA IOPERA( 234),IX( 234),IY( 234)/'DRAW',  -1,  -9/
      DATA IOPERA( 235),IX( 235),IY( 235)/'MOVE',  -8,  12/
      DATA IOPERA( 236),IX( 236),IY( 236)/'DRAW',  -6,  11/
      DATA IOPERA( 237),IX( 237),IY( 237)/'MOVE',  -7,  12/
      DATA IOPERA( 238),IX( 238),IY( 238)/'DRAW',  -6,  10/
      DATA IOPERA( 239),IX( 239),IY( 239)/'MOVE',  -3,  12/
      DATA IOPERA( 240),IX( 240),IY( 240)/'DRAW',  -4,  10/
      DATA IOPERA( 241),IX( 241),IY( 241)/'MOVE',  -2,  12/
      DATA IOPERA( 242),IX( 242),IY( 242)/'DRAW',  -4,  11/
      DATA IOPERA( 243),IX( 243),IY( 243)/'MOVE',  -6,  -8/
      DATA IOPERA( 244),IX( 244),IY( 244)/'DRAW',  -8,  -9/
      DATA IOPERA( 245),IX( 245),IY( 245)/'MOVE',  -6,  -7/
      DATA IOPERA( 246),IX( 246),IY( 246)/'DRAW',  -7,  -9/
      DATA IOPERA( 247),IX( 247),IY( 247)/'MOVE',  -4,  -7/
      DATA IOPERA( 248),IX( 248),IY( 248)/'DRAW',  -3,  -9/
      DATA IOPERA( 249),IX( 249),IY( 249)/'MOVE',  -4,  -8/
      DATA IOPERA( 250),IX( 250),IY( 250)/'DRAW',  -2,  -9/
C
      DATA IXMIND(  18)/ -11/
      DATA IXMAXD(  18)/  11/
      DATA IXDELD(  18)/  22/
      DATA ISTARD(  18)/ 189/
      DATA NUMCOO(  18)/  62/
C
C     DEFINE CHARACTER   3019--UPPER CASE S
C
      DATA IOPERA( 251),IX( 251),IY( 251)/'MOVE',   6,   9/
      DATA IOPERA( 252),IX( 252),IY( 252)/'DRAW',   7,  12/
      DATA IOPERA( 253),IX( 253),IY( 253)/'DRAW',   7,   6/
      DATA IOPERA( 254),IX( 254),IY( 254)/'DRAW',   6,   9/
      DATA IOPERA( 255),IX( 255),IY( 255)/'DRAW',   4,  11/
      DATA IOPERA( 256),IX( 256),IY( 256)/'DRAW',   1,  12/
      DATA IOPERA( 257),IX( 257),IY( 257)/'DRAW',  -2,  12/
      DATA IOPERA( 258),IX( 258),IY( 258)/'DRAW',  -5,  11/
      DATA IOPERA( 259),IX( 259),IY( 259)/'DRAW',  -7,   9/
      DATA IOPERA( 260),IX( 260),IY( 260)/'DRAW',  -7,   6/
      DATA IOPERA( 261),IX( 261),IY( 261)/'DRAW',  -6,   4/
      DATA IOPERA( 262),IX( 262),IY( 262)/'DRAW',  -3,   2/
      DATA IOPERA( 263),IX( 263),IY( 263)/'DRAW',   3,   0/
      DATA IOPERA( 264),IX( 264),IY( 264)/'DRAW',   5,  -1/
      DATA IOPERA( 265),IX( 265),IY( 265)/'DRAW',   6,  -3/
      DATA IOPERA( 266),IX( 266),IY( 266)/'DRAW',   6,  -6/
      DATA IOPERA( 267),IX( 267),IY( 267)/'DRAW',   5,  -8/
      DATA IOPERA( 268),IX( 268),IY( 268)/'MOVE',  -6,   6/
      DATA IOPERA( 269),IX( 269),IY( 269)/'DRAW',  -5,   4/
      DATA IOPERA( 270),IX( 270),IY( 270)/'DRAW',  -3,   3/
      DATA IOPERA( 271),IX( 271),IY( 271)/'DRAW',   3,   1/
      DATA IOPERA( 272),IX( 272),IY( 272)/'DRAW',   5,   0/
      DATA IOPERA( 273),IX( 273),IY( 273)/'DRAW',   6,  -2/
      DATA IOPERA( 274),IX( 274),IY( 274)/'MOVE',  -5,  11/
      DATA IOPERA( 275),IX( 275),IY( 275)/'DRAW',  -6,   9/
      DATA IOPERA( 276),IX( 276),IY( 276)/'DRAW',  -6,   7/
      DATA IOPERA( 277),IX( 277),IY( 277)/'DRAW',  -5,   5/
      DATA IOPERA( 278),IX( 278),IY( 278)/'DRAW',  -3,   4/
      DATA IOPERA( 279),IX( 279),IY( 279)/'DRAW',   3,   2/
      DATA IOPERA( 280),IX( 280),IY( 280)/'DRAW',   6,   0/
      DATA IOPERA( 281),IX( 281),IY( 281)/'DRAW',   7,  -2/
      DATA IOPERA( 282),IX( 282),IY( 282)/'DRAW',   7,  -5/
      DATA IOPERA( 283),IX( 283),IY( 283)/'DRAW',   6,  -7/
      DATA IOPERA( 284),IX( 284),IY( 284)/'DRAW',   5,  -8/
      DATA IOPERA( 285),IX( 285),IY( 285)/'DRAW',   2,  -9/
      DATA IOPERA( 286),IX( 286),IY( 286)/'DRAW',  -1,  -9/
      DATA IOPERA( 287),IX( 287),IY( 287)/'DRAW',  -4,  -8/
      DATA IOPERA( 288),IX( 288),IY( 288)/'DRAW',  -6,  -6/
      DATA IOPERA( 289),IX( 289),IY( 289)/'DRAW',  -7,  -3/
      DATA IOPERA( 290),IX( 290),IY( 290)/'DRAW',  -7,  -9/
      DATA IOPERA( 291),IX( 291),IY( 291)/'DRAW',  -6,  -6/
C
      DATA IXMIND(  19)/ -10/
      DATA IXMAXD(  19)/  10/
      DATA IXDELD(  19)/  20/
      DATA ISTARD(  19)/ 251/
      DATA NUMCOO(  19)/  41/
C
C-----START POINT-----------------------------------------------------
C
      IFOUND='YES'
      IERROR='NO'
C
      NUMCO=1
      ISTART=1
      ISTOP=1
      NC=1
C
C               ******************************************
C               **  TREAT THE ROMAN SIMPLEX UPPER CASE  **
C               **  HERSHEY CHARACTER SET CASE          **
C               ******************************************
C
C
      IF(IBUGD2.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DRTU3--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ICHARN
   52 FORMAT('ICHARN = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR
   59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               **************************************
C               **  STEP 2--                        **
C               **  EXTRACT THE COORDINATES         **
C               **  FOR THIS PARTICULAR CHARACTER.  **
C               **************************************
C
 1000 CONTINUE
      ISTART=ISTARD(ICHARN)
      NC=NUMCOO(ICHARN)
      ISTOP=ISTART+NC-1
      J=0
      DO1100I=ISTART,ISTOP
      J=J+1
      IOP(J)=IOPERA(I)
      X(J)=IX(I)
      Y(J)=IY(I)
 1100 CONTINUE
      NUMCO=J
      IXMINS=IXMIND(ICHARN)
      IXMAXS=IXMAXD(ICHARN)
      IXDELS=IXDELD(ICHARN)
C
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGD2.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DRTU3--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR
 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)ICHARN
 9013 FORMAT('ICHARN = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO
 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8)
      CALL DPWRST('XXX','BUG ')
      IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019
      DO9015I=1,NUMCO
      WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I)
 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9019 CONTINUE
      WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS
 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DRTU4(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
     1IBUGD2,IFOUND,IERROR)
C
C     PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES
C              FOR ROMAN TRIPLEX UPPER CASE (PART 4).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/4
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH     1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MARCH     1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IOP
      CHARACTER*4 IBUGD2
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IOPERA
C
C---------------------------------------------------------------------
C
      DIMENSION IOP(*)
      DIMENSION X(*)
      DIMENSION Y(*)
C
      DIMENSION IOPERA(300)
      DIMENSION IX(300)
      DIMENSION IY(300)
C
      DIMENSION IXMIND(30)
      DIMENSION IXMAXD(30)
      DIMENSION IXDELD(30)
      DIMENSION ISTARD(30)
      DIMENSION NUMCOO(30)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C     DEFINE CHARACTER   3020--UPPER CASE T
C
      DATA IOPERA(   1),IX(   1),IY(   1)/'MOVE',  -8,  12/
      DATA IOPERA(   2),IX(   2),IY(   2)/'DRAW',  -8,   6/
      DATA IOPERA(   3),IX(   3),IY(   3)/'MOVE',  -1,  12/
      DATA IOPERA(   4),IX(   4),IY(   4)/'DRAW',  -1,  -9/
      DATA IOPERA(   5),IX(   5),IY(   5)/'MOVE',   0,  11/
      DATA IOPERA(   6),IX(   6),IY(   6)/'DRAW',   0,  -8/
      DATA IOPERA(   7),IX(   7),IY(   7)/'MOVE',   1,  12/
      DATA IOPERA(   8),IX(   8),IY(   8)/'DRAW',   1,  -9/
      DATA IOPERA(   9),IX(   9),IY(   9)/'MOVE',   8,  12/
      DATA IOPERA(  10),IX(  10),IY(  10)/'DRAW',   8,   6/
      DATA IOPERA(  11),IX(  11),IY(  11)/'MOVE',  -8,  12/
      DATA IOPERA(  12),IX(  12),IY(  12)/'DRAW',   8,  12/
      DATA IOPERA(  13),IX(  13),IY(  13)/'MOVE',  -4,  -9/
      DATA IOPERA(  14),IX(  14),IY(  14)/'DRAW',   4,  -9/
      DATA IOPERA(  15),IX(  15),IY(  15)/'MOVE',  -7,  12/
      DATA IOPERA(  16),IX(  16),IY(  16)/'DRAW',  -8,   6/
      DATA IOPERA(  17),IX(  17),IY(  17)/'MOVE',  -6,  12/
      DATA IOPERA(  18),IX(  18),IY(  18)/'DRAW',  -8,   9/
      DATA IOPERA(  19),IX(  19),IY(  19)/'MOVE',  -5,  12/
      DATA IOPERA(  20),IX(  20),IY(  20)/'DRAW',  -8,  10/
      DATA IOPERA(  21),IX(  21),IY(  21)/'MOVE',  -3,  12/
      DATA IOPERA(  22),IX(  22),IY(  22)/'DRAW',  -8,  11/
      DATA IOPERA(  23),IX(  23),IY(  23)/'MOVE',   3,  12/
      DATA IOPERA(  24),IX(  24),IY(  24)/'DRAW',   8,  11/
      DATA IOPERA(  25),IX(  25),IY(  25)/'MOVE',   5,  12/
      DATA IOPERA(  26),IX(  26),IY(  26)/'DRAW',   8,  10/
      DATA IOPERA(  27),IX(  27),IY(  27)/'MOVE',   6,  12/
      DATA IOPERA(  28),IX(  28),IY(  28)/'DRAW',   8,   9/
      DATA IOPERA(  29),IX(  29),IY(  29)/'MOVE',   7,  12/
      DATA IOPERA(  30),IX(  30),IY(  30)/'DRAW',   8,   6/
      DATA IOPERA(  31),IX(  31),IY(  31)/'MOVE',  -1,  -8/
      DATA IOPERA(  32),IX(  32),IY(  32)/'DRAW',  -3,  -9/
      DATA IOPERA(  33),IX(  33),IY(  33)/'MOVE',  -1,  -7/
      DATA IOPERA(  34),IX(  34),IY(  34)/'DRAW',  -2,  -9/
      DATA IOPERA(  35),IX(  35),IY(  35)/'MOVE',   1,  -7/
      DATA IOPERA(  36),IX(  36),IY(  36)/'DRAW',   2,  -9/
      DATA IOPERA(  37),IX(  37),IY(  37)/'MOVE',   1,  -8/
      DATA IOPERA(  38),IX(  38),IY(  38)/'DRAW',   3,  -9/
C
      DATA IXMIND(  20)/ -10/
      DATA IXMAXD(  20)/  10/
      DATA IXDELD(  20)/  20/
      DATA ISTARD(  20)/   1/
      DATA NUMCOO(  20)/  38/
C
C     DEFINE CHARACTER   3021--UPPER CASE U
C
      DATA IOPERA(  39),IX(  39),IY(  39)/'MOVE',  -7,  12/
      DATA IOPERA(  40),IX(  40),IY(  40)/'DRAW',  -7,  -3/
      DATA IOPERA(  41),IX(  41),IY(  41)/'DRAW',  -6,  -6/
      DATA IOPERA(  42),IX(  42),IY(  42)/'DRAW',  -4,  -8/
      DATA IOPERA(  43),IX(  43),IY(  43)/'DRAW',  -1,  -9/
      DATA IOPERA(  44),IX(  44),IY(  44)/'DRAW',   1,  -9/
      DATA IOPERA(  45),IX(  45),IY(  45)/'DRAW',   4,  -8/
      DATA IOPERA(  46),IX(  46),IY(  46)/'DRAW',   6,  -6/
      DATA IOPERA(  47),IX(  47),IY(  47)/'DRAW',   7,  -3/
      DATA IOPERA(  48),IX(  48),IY(  48)/'DRAW',   7,  11/
      DATA IOPERA(  49),IX(  49),IY(  49)/'MOVE',  -6,  11/
      DATA IOPERA(  50),IX(  50),IY(  50)/'DRAW',  -6,  -4/
      DATA IOPERA(  51),IX(  51),IY(  51)/'DRAW',  -5,  -6/
      DATA IOPERA(  52),IX(  52),IY(  52)/'MOVE',  -5,  12/
      DATA IOPERA(  53),IX(  53),IY(  53)/'DRAW',  -5,  -4/
      DATA IOPERA(  54),IX(  54),IY(  54)/'DRAW',  -4,  -7/
      DATA IOPERA(  55),IX(  55),IY(  55)/'DRAW',  -3,  -8/
      DATA IOPERA(  56),IX(  56),IY(  56)/'DRAW',  -1,  -9/
      DATA IOPERA(  57),IX(  57),IY(  57)/'MOVE', -10,  12/
      DATA IOPERA(  58),IX(  58),IY(  58)/'DRAW',  -2,  12/
      DATA IOPERA(  59),IX(  59),IY(  59)/'MOVE',   4,  12/
      DATA IOPERA(  60),IX(  60),IY(  60)/'DRAW',  10,  12/
      DATA IOPERA(  61),IX(  61),IY(  61)/'MOVE',  -9,  12/
      DATA IOPERA(  62),IX(  62),IY(  62)/'DRAW',  -7,  11/
      DATA IOPERA(  63),IX(  63),IY(  63)/'MOVE',  -8,  12/
      DATA IOPERA(  64),IX(  64),IY(  64)/'DRAW',  -7,  10/
      DATA IOPERA(  65),IX(  65),IY(  65)/'MOVE',  -4,  12/
      DATA IOPERA(  66),IX(  66),IY(  66)/'DRAW',  -5,  10/
      DATA IOPERA(  67),IX(  67),IY(  67)/'MOVE',  -3,  12/
      DATA IOPERA(  68),IX(  68),IY(  68)/'DRAW',  -5,  11/
      DATA IOPERA(  69),IX(  69),IY(  69)/'MOVE',   5,  12/
      DATA IOPERA(  70),IX(  70),IY(  70)/'DRAW',   7,  11/
      DATA IOPERA(  71),IX(  71),IY(  71)/'MOVE',   9,  12/
      DATA IOPERA(  72),IX(  72),IY(  72)/'DRAW',   7,  11/
C
      DATA IXMIND(  21)/ -12/
      DATA IXMAXD(  21)/  12/
      DATA IXDELD(  21)/  24/
      DATA ISTARD(  21)/  39/
      DATA NUMCOO(  21)/  34/
C
C     DEFINE CHARACTER   3022--UPPER CASE V
C
      DATA IOPERA(  73),IX(  73),IY(  73)/'MOVE',  -7,  12/
      DATA IOPERA(  74),IX(  74),IY(  74)/'DRAW',   0,  -9/
      DATA IOPERA(  75),IX(  75),IY(  75)/'MOVE',  -6,  12/
      DATA IOPERA(  76),IX(  76),IY(  76)/'DRAW',   0,  -6/
      DATA IOPERA(  77),IX(  77),IY(  77)/'DRAW',   0,  -9/
      DATA IOPERA(  78),IX(  78),IY(  78)/'MOVE',  -5,  12/
      DATA IOPERA(  79),IX(  79),IY(  79)/'DRAW',   1,  -6/
      DATA IOPERA(  80),IX(  80),IY(  80)/'MOVE',   7,  11/
      DATA IOPERA(  81),IX(  81),IY(  81)/'DRAW',   0,  -9/
      DATA IOPERA(  82),IX(  82),IY(  82)/'MOVE',  -9,  12/
      DATA IOPERA(  83),IX(  83),IY(  83)/'DRAW',  -2,  12/
      DATA IOPERA(  84),IX(  84),IY(  84)/'MOVE',   3,  12/
      DATA IOPERA(  85),IX(  85),IY(  85)/'DRAW',   9,  12/
      DATA IOPERA(  86),IX(  86),IY(  86)/'MOVE',  -8,  12/
      DATA IOPERA(  87),IX(  87),IY(  87)/'DRAW',  -6,  10/
      DATA IOPERA(  88),IX(  88),IY(  88)/'MOVE',  -4,  12/
      DATA IOPERA(  89),IX(  89),IY(  89)/'DRAW',  -5,  10/
      DATA IOPERA(  90),IX(  90),IY(  90)/'MOVE',  -3,  12/
      DATA IOPERA(  91),IX(  91),IY(  91)/'DRAW',  -5,  11/
      DATA IOPERA(  92),IX(  92),IY(  92)/'MOVE',   5,  12/
      DATA IOPERA(  93),IX(  93),IY(  93)/'DRAW',   7,  11/
      DATA IOPERA(  94),IX(  94),IY(  94)/'MOVE',   8,  12/
      DATA IOPERA(  95),IX(  95),IY(  95)/'DRAW',   7,  11/
C
      DATA IXMIND(  22)/ -10/
      DATA IXMAXD(  22)/  10/
      DATA IXDELD(  22)/  20/
      DATA ISTARD(  22)/  73/
      DATA NUMCOO(  22)/  23/
C
C     DEFINE CHARACTER   3023--UPPER CASE W
C
      DATA IOPERA(  96),IX(  96),IY(  96)/'MOVE',  -8,  12/
      DATA IOPERA(  97),IX(  97),IY(  97)/'DRAW',  -4,  -9/
      DATA IOPERA(  98),IX(  98),IY(  98)/'MOVE',  -7,  12/
      DATA IOPERA(  99),IX(  99),IY(  99)/'DRAW',  -4,  -4/
      DATA IOPERA( 100),IX( 100),IY( 100)/'DRAW',  -4,  -9/
      DATA IOPERA( 101),IX( 101),IY( 101)/'MOVE',  -6,  12/
      DATA IOPERA( 102),IX( 102),IY( 102)/'DRAW',  -3,  -4/
      DATA IOPERA( 103),IX( 103),IY( 103)/'MOVE',   0,  12/
      DATA IOPERA( 104),IX( 104),IY( 104)/'DRAW',  -3,  -4/
      DATA IOPERA( 105),IX( 105),IY( 105)/'DRAW',  -4,  -9/
      DATA IOPERA( 106),IX( 106),IY( 106)/'MOVE',   0,  12/
      DATA IOPERA( 107),IX( 107),IY( 107)/'DRAW',   4,  -9/
      DATA IOPERA( 108),IX( 108),IY( 108)/'MOVE',   1,  12/
      DATA IOPERA( 109),IX( 109),IY( 109)/'DRAW',   4,  -4/
      DATA IOPERA( 110),IX( 110),IY( 110)/'DRAW',   4,  -9/
      DATA IOPERA( 111),IX( 111),IY( 111)/'MOVE',   2,  12/
      DATA IOPERA( 112),IX( 112),IY( 112)/'DRAW',   5,  -4/
      DATA IOPERA( 113),IX( 113),IY( 113)/'MOVE',   8,  11/
      DATA IOPERA( 114),IX( 114),IY( 114)/'DRAW',   5,  -4/
      DATA IOPERA( 115),IX( 115),IY( 115)/'DRAW',   4,  -9/
      DATA IOPERA( 116),IX( 116),IY( 116)/'MOVE', -11,  12/
      DATA IOPERA( 117),IX( 117),IY( 117)/'DRAW',  -3,  12/
      DATA IOPERA( 118),IX( 118),IY( 118)/'MOVE',   0,  12/
      DATA IOPERA( 119),IX( 119),IY( 119)/'DRAW',   2,  12/
      DATA IOPERA( 120),IX( 120),IY( 120)/'MOVE',   5,  12/
      DATA IOPERA( 121),IX( 121),IY( 121)/'DRAW',  11,  12/
      DATA IOPERA( 122),IX( 122),IY( 122)/'MOVE', -10,  12/
      DATA IOPERA( 123),IX( 123),IY( 123)/'DRAW',  -7,  11/
      DATA IOPERA( 124),IX( 124),IY( 124)/'MOVE',  -9,  12/
      DATA IOPERA( 125),IX( 125),IY( 125)/'DRAW',  -7,  10/
      DATA IOPERA( 126),IX( 126),IY( 126)/'MOVE',  -5,  12/
      DATA IOPERA( 127),IX( 127),IY( 127)/'DRAW',  -6,  10/
      DATA IOPERA( 128),IX( 128),IY( 128)/'MOVE',  -4,  12/
      DATA IOPERA( 129),IX( 129),IY( 129)/'DRAW',  -6,  11/
      DATA IOPERA( 130),IX( 130),IY( 130)/'MOVE',   6,  12/
      DATA IOPERA( 131),IX( 131),IY( 131)/'DRAW',   8,  11/
      DATA IOPERA( 132),IX( 132),IY( 132)/'MOVE',  10,  12/
      DATA IOPERA( 133),IX( 133),IY( 133)/'DRAW',   8,  11/
C
      DATA IXMIND(  23)/ -12/
      DATA IXMAXD(  23)/  12/
      DATA IXDELD(  23)/  24/
      DATA ISTARD(  23)/  96/
      DATA NUMCOO(  23)/  38/
C
C     DEFINE CHARACTER   3024--UPPER CASE X
C
      DATA IOPERA( 134),IX( 134),IY( 134)/'MOVE',  -7,  12/
      DATA IOPERA( 135),IX( 135),IY( 135)/'DRAW',   5,  -9/
      DATA IOPERA( 136),IX( 136),IY( 136)/'MOVE',  -6,  12/
      DATA IOPERA( 137),IX( 137),IY( 137)/'DRAW',   6,  -9/
      DATA IOPERA( 138),IX( 138),IY( 138)/'MOVE',  -5,  12/
      DATA IOPERA( 139),IX( 139),IY( 139)/'DRAW',   7,  -9/
      DATA IOPERA( 140),IX( 140),IY( 140)/'MOVE',   6,  11/
      DATA IOPERA( 141),IX( 141),IY( 141)/'DRAW',  -6,  -8/
      DATA IOPERA( 142),IX( 142),IY( 142)/'MOVE',  -9,  12/
      DATA IOPERA( 143),IX( 143),IY( 143)/'DRAW',  -2,  12/
      DATA IOPERA( 144),IX( 144),IY( 144)/'MOVE',   3,  12/
      DATA IOPERA( 145),IX( 145),IY( 145)/'DRAW',   9,  12/
      DATA IOPERA( 146),IX( 146),IY( 146)/'MOVE',  -9,  -9/
      DATA IOPERA( 147),IX( 147),IY( 147)/'DRAW',  -3,  -9/
      DATA IOPERA( 148),IX( 148),IY( 148)/'MOVE',   2,  -9/
      DATA IOPERA( 149),IX( 149),IY( 149)/'DRAW',   9,  -9/
      DATA IOPERA( 150),IX( 150),IY( 150)/'MOVE',  -8,  12/
      DATA IOPERA( 151),IX( 151),IY( 151)/'DRAW',  -5,  10/
      DATA IOPERA( 152),IX( 152),IY( 152)/'MOVE',  -4,  12/
      DATA IOPERA( 153),IX( 153),IY( 153)/'DRAW',  -5,  10/
      DATA IOPERA( 154),IX( 154),IY( 154)/'MOVE',  -3,  12/
      DATA IOPERA( 155),IX( 155),IY( 155)/'DRAW',  -5,  11/
      DATA IOPERA( 156),IX( 156),IY( 156)/'MOVE',   4,  12/
      DATA IOPERA( 157),IX( 157),IY( 157)/'DRAW',   6,  11/
      DATA IOPERA( 158),IX( 158),IY( 158)/'MOVE',   8,  12/
      DATA IOPERA( 159),IX( 159),IY( 159)/'DRAW',   6,  11/
      DATA IOPERA( 160),IX( 160),IY( 160)/'MOVE',  -6,  -8/
      DATA IOPERA( 161),IX( 161),IY( 161)/'DRAW',  -8,  -9/
      DATA IOPERA( 162),IX( 162),IY( 162)/'MOVE',  -6,  -8/
      DATA IOPERA( 163),IX( 163),IY( 163)/'DRAW',  -4,  -9/
      DATA IOPERA( 164),IX( 164),IY( 164)/'MOVE',   5,  -8/
      DATA IOPERA( 165),IX( 165),IY( 165)/'DRAW',   3,  -9/
      DATA IOPERA( 166),IX( 166),IY( 166)/'MOVE',   5,  -7/
      DATA IOPERA( 167),IX( 167),IY( 167)/'DRAW',   4,  -9/
      DATA IOPERA( 168),IX( 168),IY( 168)/'MOVE',   5,  -7/
      DATA IOPERA( 169),IX( 169),IY( 169)/'DRAW',   8,  -9/
C
      DATA IXMIND(  24)/ -10/
      DATA IXMAXD(  24)/  10/
      DATA IXDELD(  24)/  20/
      DATA ISTARD(  24)/ 134/
      DATA NUMCOO(  24)/  36/
C
C     DEFINE CHARACTER   3025--UPPER CASE Y
C
      DATA IOPERA( 170),IX( 170),IY( 170)/'MOVE',  -8,  12/
      DATA IOPERA( 171),IX( 171),IY( 171)/'DRAW',  -1,   1/
      DATA IOPERA( 172),IX( 172),IY( 172)/'DRAW',  -1,  -9/
      DATA IOPERA( 173),IX( 173),IY( 173)/'MOVE',  -7,  12/
      DATA IOPERA( 174),IX( 174),IY( 174)/'DRAW',   0,   1/
      DATA IOPERA( 175),IX( 175),IY( 175)/'DRAW',   0,  -8/
      DATA IOPERA( 176),IX( 176),IY( 176)/'MOVE',  -6,  12/
      DATA IOPERA( 177),IX( 177),IY( 177)/'DRAW',   1,   1/
      DATA IOPERA( 178),IX( 178),IY( 178)/'DRAW',   1,  -9/
      DATA IOPERA( 179),IX( 179),IY( 179)/'MOVE',   7,  11/
      DATA IOPERA( 180),IX( 180),IY( 180)/'DRAW',   1,   1/
      DATA IOPERA( 181),IX( 181),IY( 181)/'MOVE', -10,  12/
      DATA IOPERA( 182),IX( 182),IY( 182)/'DRAW',  -3,  12/
      DATA IOPERA( 183),IX( 183),IY( 183)/'MOVE',   4,  12/
      DATA IOPERA( 184),IX( 184),IY( 184)/'DRAW',  10,  12/
      DATA IOPERA( 185),IX( 185),IY( 185)/'MOVE',  -4,  -9/
      DATA IOPERA( 186),IX( 186),IY( 186)/'DRAW',   4,  -9/
      DATA IOPERA( 187),IX( 187),IY( 187)/'MOVE',  -9,  12/
      DATA IOPERA( 188),IX( 188),IY( 188)/'DRAW',  -7,  11/
      DATA IOPERA( 189),IX( 189),IY( 189)/'MOVE',  -4,  12/
      DATA IOPERA( 190),IX( 190),IY( 190)/'DRAW',  -6,  11/
      DATA IOPERA( 191),IX( 191),IY( 191)/'MOVE',   5,  12/
      DATA IOPERA( 192),IX( 192),IY( 192)/'DRAW',   7,  11/
      DATA IOPERA( 193),IX( 193),IY( 193)/'MOVE',   9,  12/
      DATA IOPERA( 194),IX( 194),IY( 194)/'DRAW',   7,  11/
      DATA IOPERA( 195),IX( 195),IY( 195)/'MOVE',  -1,  -8/
      DATA IOPERA( 196),IX( 196),IY( 196)/'DRAW',  -3,  -9/
      DATA IOPERA( 197),IX( 197),IY( 197)/'MOVE',  -1,  -7/
      DATA IOPERA( 198),IX( 198),IY( 198)/'DRAW',  -2,  -9/
      DATA IOPERA( 199),IX( 199),IY( 199)/'MOVE',   1,  -7/
      DATA IOPERA( 200),IX( 200),IY( 200)/'DRAW',   2,  -9/
      DATA IOPERA( 201),IX( 201),IY( 201)/'MOVE',   1,  -8/
      DATA IOPERA( 202),IX( 202),IY( 202)/'DRAW',   3,  -9/
C
      DATA IXMIND(  25)/ -11/
      DATA IXMAXD(  25)/  11/
      DATA IXDELD(  25)/  22/
      DATA ISTARD(  25)/ 170/
      DATA NUMCOO(  25)/  33/
C
C     DEFINE CHARACTER   3026--UPPER CASE Z
C
      DATA IOPERA( 203),IX( 203),IY( 203)/'MOVE',   7,  12/
      DATA IOPERA( 204),IX( 204),IY( 204)/'DRAW',  -7,  12/
      DATA IOPERA( 205),IX( 205),IY( 205)/'DRAW',  -7,   6/
      DATA IOPERA( 206),IX( 206),IY( 206)/'MOVE',   5,  12/
      DATA IOPERA( 207),IX( 207),IY( 207)/'DRAW',  -7,  -9/
      DATA IOPERA( 208),IX( 208),IY( 208)/'MOVE',   6,  12/
      DATA IOPERA( 209),IX( 209),IY( 209)/'DRAW',  -6,  -9/
      DATA IOPERA( 210),IX( 210),IY( 210)/'MOVE',   7,  12/
      DATA IOPERA( 211),IX( 211),IY( 211)/'DRAW',  -5,  -9/
      DATA IOPERA( 212),IX( 212),IY( 212)/'MOVE',  -7,  -9/
      DATA IOPERA( 213),IX( 213),IY( 213)/'DRAW',   7,  -9/
      DATA IOPERA( 214),IX( 214),IY( 214)/'DRAW',   7,  -3/
      DATA IOPERA( 215),IX( 215),IY( 215)/'MOVE',  -6,  12/
      DATA IOPERA( 216),IX( 216),IY( 216)/'DRAW',  -7,   6/
      DATA IOPERA( 217),IX( 217),IY( 217)/'MOVE',  -5,  12/
      DATA IOPERA( 218),IX( 218),IY( 218)/'DRAW',  -7,   9/
      DATA IOPERA( 219),IX( 219),IY( 219)/'MOVE',  -4,  12/
      DATA IOPERA( 220),IX( 220),IY( 220)/'DRAW',  -7,  10/
      DATA IOPERA( 221),IX( 221),IY( 221)/'MOVE',  -2,  12/
      DATA IOPERA( 222),IX( 222),IY( 222)/'DRAW',  -7,  11/
      DATA IOPERA( 223),IX( 223),IY( 223)/'MOVE',   2,  -9/
      DATA IOPERA( 224),IX( 224),IY( 224)/'DRAW',   7,  -8/
      DATA IOPERA( 225),IX( 225),IY( 225)/'MOVE',   4,  -9/
      DATA IOPERA( 226),IX( 226),IY( 226)/'DRAW',   7,  -7/
      DATA IOPERA( 227),IX( 227),IY( 227)/'MOVE',   5,  -9/
      DATA IOPERA( 228),IX( 228),IY( 228)/'DRAW',   7,  -6/
      DATA IOPERA( 229),IX( 229),IY( 229)/'MOVE',   6,  -9/
      DATA IOPERA( 230),IX( 230),IY( 230)/'DRAW',   7,  -3/
C
      DATA IXMIND(  26)/ -10/
      DATA IXMAXD(  26)/  10/
      DATA IXDELD(  26)/  20/
      DATA ISTARD(  26)/ 203/
      DATA NUMCOO(  26)/  28/
C
C-----START POINT-----------------------------------------------------
C
      IFOUND='YES'
      IERROR='NO'
C
      NUMCO=1
      ISTART=1
      ISTOP=1
      NC=1
C
C               ******************************************
C               **  TREAT THE ROMAN SIMPLEX UPPER CASE  **
C               **  HERSHEY CHARACTER SET CASE          **
C               ******************************************
C
C
      IF(IBUGD2.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DRTU4--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ICHARN
   52 FORMAT('ICHARN = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR
   59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               **************************************
C               **  STEP 2--                        **
C               **  EXTRACT THE COORDINATES         **
C               **  FOR THIS PARTICULAR CHARACTER.  **
C               **************************************
C
 1000 CONTINUE
      ISTART=ISTARD(ICHARN)
      NC=NUMCOO(ICHARN)
      ISTOP=ISTART+NC-1
      J=0
      DO1100I=ISTART,ISTOP
      J=J+1
      IOP(J)=IOPERA(I)
      X(J)=IX(I)
      Y(J)=IY(I)
 1100 CONTINUE
      NUMCO=J
      IXMINS=IXMIND(ICHARN)
      IXMAXS=IXMAXD(ICHARN)
      IXDELS=IXDELD(ICHARN)
C
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGD2.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DRTU4--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR
 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)ICHARN
 9013 FORMAT('ICHARN = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO
 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8)
      CALL DPWRST('XXX','BUG ')
      IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019
      DO9015I=1,NUMCO
      WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I)
 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9019 CONTINUE
      WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS
 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DRWFIL(XC,YC,NMX,NSEG,NPTS,SNSE,CLSD,NSGX,X,Y,IMX,
     1  JMX,IB,JB,NBX,PRMTR,NS,D,CN,WLN,IDSH,KOLR,LBL,LDEC,SZL,DLMM,
     1XTEMP,YTEMP,TATEMP,NTEMP,NTRACE,
     1IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--XX
C
C     WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI).
C                 AS PART OF NOAA'S CONCX V.3   MARCH 1988.
C     ORIGINAL VERSION (IN DATAPLOT)--AUGUST    1988.
C
C     UPDATED         --JANUARY   1989.  MORE CHANGES TO STANDARD FORTRAN 77--
C                                        REPLACED ENCODE WITH
C                                        INTERNAL WRITE (ALAN HECKERT).
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOCP.INC'
C
C---------------------------------------------------------------------
C
      CHARACTER CHR(15)*1
      CHARACTER*15 CHRTMP
C
CCCCC INTEGER NPTS(NSGX,3),SNSE(NSGX,3),CLSD(NSGX,3),NSEG(3),NSGE(3),
CCCCC1 NSGCL(3),NSGCH(3),NTPE(3),NTPCL(3),NTPCH(3)
CCCCC DIMENSION XC(NMX,3),YC(NMX,3),D(2,NSGX,3),IB(NBX),JB(NBX),
CCCCC1 X(IMX),Y(JMX),NS(2,NSGX,3)
C
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      INTEGER NPTS
      INTEGER SNSE
      INTEGER CLSD
      INTEGER NSEG
      INTEGER NSGE
      INTEGER NSGCL
      INTEGER NSGCH
      INTEGER NTPE
      INTEGER NTPCL
      INTEGER NTPCH
C
      DIMENSION NPTS(MAXNSG,3)
      DIMENSION SNSE(MAXNSG,3)
      DIMENSION CLSD(MAXNSG,3)
      DIMENSION NSEG(3)
      DIMENSION NSGE(3)
      DIMENSION NSGCL(3)
      DIMENSION NSGCH(3)
      DIMENSION NTPE(3)
      DIMENSION NTPCL(3)
      DIMENSION NTPCH(3)
C
      DIMENSION XC(MAXNMX,3)
      DIMENSION YC(MAXNMX,3)
      DIMENSION D(2,MAXNSG,3)
      DIMENSION IB(*)
      DIMENSION JB(*)
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION NS(2,MAXNSG,3)
C
      DIMENSION XTEMP(*)
      DIMENSION YTEMP(*)
      DIMENSION TATEMP(*)
C
      DATA FRM/0.0/
C
C-----START POINT-----------------------------------------------------
C
C   SORT THE CONTOUR SEGMENTS AND CREATE POLYGONS FOR COLOR FILL
C
      CALL PLYSRT(XC,YC,NMX,NSEG,NSGE,NSGCL,NSGCH,NPTS,NTPE,NTPCL,
     1   NTPCH,SNSE,CLSD,NSGX,X,Y,IMX,JMX,IB,JB,NBX,PRMTR,NS,D)
C
C   FILL THE POLYGONS WITH COLOR
C
      IF (KOLR.GE.0) THEN
        L1=1
        DO 10 N=1,NSEG(3)
          NP=NPTS(N,3)
          CALL RSURF(XC(L1,3),YC(L1,3),NP,KOLR,FRM,
     1XTEMP,YTEMP,TATEMP,NTEMP,NTRACE,
     1IBUGG3,ISUBRO,IERROR)
          L1=L1+NP
 10     CONTINUE
      END IF
C
C   DRAW THE CONTOURS (USE *(*,3) ARRAYS TO PREVENT DATA LOSS DUE TO GVECT)
C
      IF (CN.NE.999.999) THEN
CCCCC   CALL GWICOL(WLN,1)    AUGUST 1988
        IF (LBL.GT.0) THEN
          IPOW=MAX0(LDEC+1,1)
CCCCC THE FOLLOWING 2 LINES WERE CORRECTED JANUARY 1989
CCCCC     ENCODE(15,999,CHR) CN+SIGN(10.**-IPOW,CN)
C999      FORMAT(F15.5)
          WRITE(CHRTMP,'(F15.5)') CN+SIGN(10.**(-IPOW),CN)
          DO 15 III=1,15
            CHR(III)=CHRTMP(III:III)
 15       CONTINUE
C  END CHANGE
          I=MAX0(0,INT(ALOG10(ABS(CN+SIGN(0.001,CN)))))+1
          IF (CN.LT.0.) I=I+1
          IS=MAX0(1,10-I)
          IE=10+LDEC
          DO 20 I=IS,IE
            NCHR=I-IS+1
            CHR(NCHR)=CHR(I)
 20       CONTINUE
        END IF
        L2=0
        DO 30 NSG=1,NSEG(1)
          L1=L2+1
          NP=IABS(NPTS(NSG,1))
          L2=L2+NP
          DO 40 L=L1,L2
            LL=L-L1+1
            LLL=L2-L+L1
            XC(LL,3)=XC(LLL,1)
            YC(LL,3)=YC(LLL,1)
 40       CONTINUE
          IF (LBL.LE.0) THEN
            CALL DRAW0(XC(1,3),YC(1,3),NP,IDSH,
     1XTEMP,YTEMP,TATEMP,NTEMP,NTRACE,
     1IBUGG3,ISUBRO,IERROR)
          ELSE
            CALL DRAWL(XC(1,3),YC(1,3),D(1,1,3),NP,IDSH,CHR,
     1                          NCHR,SZL,DLMM,
     1XTEMP,YTEMP,TATEMP,NTEMP,NTRACE,
     1IBUGG3,ISUBRO,IERROR)
          END IF
 30     CONTINUE
      END IF
C
C   CONVERT *(*,2) ARRAYS TO *(*,1) ARRAYS
C
      N=0
      LE=0
      DO 50 K=1,3
        IF (K.EQ.1) THEN
          NSG=NSGE(2)
          NSGE(1)=NSG
          NTPE(1)=NTPE(2)
          NN=0
          LOFF=0
        ELSE IF (K.EQ.2) THEN
          NSG=NSGCH(2)
          NSGCL(1)=NSG
          NTPCL(1)=NTPCH(2)
          NN=NSGE(2)+NSGCL(2)
          LOFF=NTPCL(2)
        ELSE
          NSG=NSGCL(2)
          NSGCH(1)=NSG
          NTPCH(1)=NTPCL(2)
          NN=NSGE(2)
          LOFF=-NTPCH(2)
        END IF
        DO 60 N0=1,NSG
          N=N+1
          NN=NN+1
          NPTS(N,1)=IABS(NPTS(NN,2))
          SNSE(N,1)=1
          CLSD(N,1)=-CLSD(NN,2)
          LS=LE+1
          LE=LE+NPTS(N,1)
          DO 70 L=LS,LE
            LL=LE-L+LS+LOFF
            XC(L,1)=XC(LL,2)
            YC(L,1)=YC(LL,2)
 70       CONTINUE
          IF (K.EQ.1) THEN
            DO 80 I=1,2
              II=MOD(I,2)+1
              NS(I,N,1)=NS(II,NN,2)
              D(I,N,1)=D(II,NN,2)
 80         CONTINUE
          ELSE
            D(1,N,1)=D(1,NN,2)
          END IF
 60     CONTINUE
 50   CONTINUE
      NSEG(1)=NSEG(2)
      RETURN
      END
      SUBROUTINE DSCAL(N,DA,DX,INCX)
C
C     SCALES A VECTOR BY A CONSTANT.
C     USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C     MODIFIED 3/93 TO RETURN IF INCX .LE. 0.
C
      DOUBLE PRECISION DA,DX(1)
      INTEGER I,INCX,M,MP1,N,NINCX
C
      IF( N.LE.0 .OR. INCX.LE.0 )RETURN
      IF(INCX.EQ.1)GO TO 20
C
C        CODE FOR INCREMENT NOT EQUAL TO 1
C
      NINCX = N*INCX
      DO 10 I = 1,NINCX,INCX
        DX(I) = DA*DX(I)
   10 CONTINUE
      RETURN
C
C        CODE FOR INCREMENT EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DX(I) = DA*DX(I)
   30 CONTINUE
      IF( N .LT. 5 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        DX(I) = DA*DX(I)
        DX(I + 1) = DA*DX(I + 1)
        DX(I + 2) = DA*DX(I + 2)
        DX(I + 3) = DA*DX(I + 3)
        DX(I + 4) = DA*DX(I + 4)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE DSET (N, X, CONST)
C
C     MARK VANGEL, NIST, JANUARY 1994
C     SUBROUTINE DSET SETS THE N VALUES IN X TO THE CONSTANT CONST
C
C
      DOUBLE PRECISION X, CONST
      DIMENSION X(N)
      DO 10 I=1, N
         X(I) = CONST
 10   CONTINUE
      RETURN
      END
      SUBROUTINE DSORT (DX, DY, N, KFLAG, IERROR)
C***BEGIN PROLOGUE  DSORT
C***PURPOSE  Sort an array and optionally make the same interchanges in
C            an auxiliary array.  The array may be sorted in increasing
C            or decreasing order.  A slightly modified QUICKSORT
C            algorithm is used.
C***LIBRARY   SLATEC
C***CATEGORY  N6A2B
C***TYPE      DOUBLE PRECISION (SSORT-S, DSORT-D, ISORT-I)
C***KEYWORDS  SINGLETON QUICKSORT, SORT, SORTING
C***AUTHOR  Jones, R. E., (SNLA)
C           Wisniewski, J. A., (SNLA)
C***DESCRIPTION
C
C   DSORT sorts array DX and optionally makes the same interchanges in
C   array DY.  The array DX may be sorted in increasing order or
C   decreasing order.  A slightly modified quicksort algorithm is used.
C
C   Description of Parameters
C      DX - array of values to be sorted   (usually abscissas)
C      DY - array to be (optionally) carried along
C      N  - number of values in array DX to be sorted
C      KFLAG - control parameter
C            =  2  means sort DX in increasing order and carry DY along.
C            =  1  means sort DX in increasing order (ignoring DY)
C            = -1  means sort DX in decreasing order (ignoring DY)
C            = -2  means sort DX in decreasing order and carry DY along.
C
C***REFERENCES  R. C. Singleton, Algorithm 347, An efficient algorithm
C                 for sorting with minimal storage, Communications of
C                 the ACM, 12, 3 (1969), pp. 185-187.
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   761101  DATE WRITTEN
C   761118  Modified to use the Singleton quicksort algorithm.  (JAW)
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891009  Removed unreferenced statement labels.  (WRB)
C   891024  Changed category.  (WRB)
C   891024  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   901012  Declared all variables; changed X,Y to DX,DY; changed
C           code to parallel SSORT. (M. McClain)
C   920501  Reformatted the REFERENCES section.  (DWL, WRB)
C   920519  Clarified error messages.  (DWL)
C   920801  Declarations section rebuilt and code restructured to use
C           IF-THEN-ELSE-ENDIF.  (RWC, WRB)
C   970821  Minor modifications to error handling and printing to
C           incorporate into Dataplot
C***END PROLOGUE  DSORT
C     .. Scalar Arguments ..
C
      CHARACTER*4 IERROR
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      INTEGER KFLAG, N
C     .. Array Arguments ..
      DOUBLE PRECISION DX(*), DY(*)
C     .. Local Scalars ..
      DOUBLE PRECISION R, T, TT, TTY, TY
      INTEGER I, IJ, J, K, KK, L, M, NN
C     .. Local Arrays ..
      INTEGER IL(21), IU(21)
C     .. External Subroutines ..
CCCCC EXTERNAL XERMSG
C     .. Intrinsic Functions ..
      INTRINSIC ABS, INT
C***FIRST EXECUTABLE STATEMENT  DSORT
      IERROR='NO'
      NN = N
      IF (NN .LT. 1) THEN
CCCCC    CALL XERMSG ('SLATEC', 'DSORT',
CCCCC+      'The number of values to be sorted is not positive.', 1, 1)
         WRITE(ICOUT,1001)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1002)
         CALL DPWRST('XXX','BUG')
         IERROR='YES'
         RETURN
      ENDIF
 1001 FORMAT('***** RECIPE ERROR: INTERNAL ERROR FROM DSORT')
 1002 FORMAT('      THE NUMBER OF VALUES TO BE SORTED IS NOT POSITIVE.')
C
      KK = ABS(KFLAG)
      IF (KK.NE.1 .AND. KK.NE.2) THEN
CCCCC    CALL XERMSG ('SLATEC', 'DSORT',
CCCCC+      'The sort control parameter, K, is not 2, 1, -1, or -2.', 2,
CCCCC+      1)
         WRITE(ICOUT,1003)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1004)
         CALL DPWRST('XXX','BUG')
         IERROR='YES'
         RETURN
      ENDIF
 1003 FORMAT('***** RECIPE ERROR: INTERNAL ERROR FROM DSORT')
 1004 FORMAT('      THE SORT CONTROL PARAMETER, K, IS NOT 2, 1, ',
     1'-1, OR -2.')
C
C     Alter array DX to get decreasing order if needed
C
      IF (KFLAG .LE. -1) THEN
         DO 10 I=1,NN
            DX(I) = -DX(I)
   10    CONTINUE
      ENDIF
C
      IF (KK .EQ. 2) GO TO 100
C
C     Sort DX only
C
      M = 1
      I = 1
      J = NN
      R = 0.375D0
C
   20 IF (I .EQ. J) GO TO 60
      IF (R .LE. 0.5898437D0) THEN
         R = R+3.90625D-2
      ELSE
         R = R-0.21875D0
      ENDIF
C
   30 K = I
C
C     Select a central element of the array and save it in location T
C
      IJ = I + INT((J-I)*R)
      T = DX(IJ)
C
C     If first element of array is greater than T, interchange with T
C
      IF (DX(I) .GT. T) THEN
         DX(IJ) = DX(I)
         DX(I) = T
         T = DX(IJ)
      ENDIF
      L = J
C
C     If last element of array is less than than T, interchange with T
C
      IF (DX(J) .LT. T) THEN
         DX(IJ) = DX(J)
         DX(J) = T
         T = DX(IJ)
C
C        If first element of array is greater than T, interchange with T
C
         IF (DX(I) .GT. T) THEN
            DX(IJ) = DX(I)
            DX(I) = T
            T = DX(IJ)
         ENDIF
      ENDIF
C
C     Find an element in the second half of the array which is smaller
C     than T
C
   40 L = L-1
      IF (DX(L) .GT. T) GO TO 40
C
C     Find an element in the first half of the array which is greater
C     than T
C
   50 K = K+1
      IF (DX(K) .LT. T) GO TO 50
C
C     Interchange these elements
C
      IF (K .LE. L) THEN
         TT = DX(L)
         DX(L) = DX(K)
         DX(K) = TT
         GO TO 40
      ENDIF
C
C     Save upper and lower subscripts of the array yet to be sorted
C
      IF (L-I .GT. J-K) THEN
         IL(M) = I
         IU(M) = L
         I = K
         M = M+1
      ELSE
         IL(M) = K
         IU(M) = J
         J = L
         M = M+1
      ENDIF
      GO TO 70
C
C     Begin again on another portion of the unsorted array
C
   60 M = M-1
      IF (M .EQ. 0) GO TO 190
      I = IL(M)
      J = IU(M)
C
   70 IF (J-I .GE. 1) GO TO 30
      IF (I .EQ. 1) GO TO 20
      I = I-1
C
   80 I = I+1
      IF (I .EQ. J) GO TO 60
      T = DX(I+1)
      IF (DX(I) .LE. T) GO TO 80
      K = I
C
   90 DX(K+1) = DX(K)
      K = K-1
      IF (T .LT. DX(K)) GO TO 90
      DX(K+1) = T
      GO TO 80
C
C     Sort DX and carry DY along
C
  100 M = 1
      I = 1
      J = NN
      R = 0.375D0
C
  110 IF (I .EQ. J) GO TO 150
      IF (R .LE. 0.5898437D0) THEN
         R = R+3.90625D-2
      ELSE
         R = R-0.21875D0
      ENDIF
C
  120 K = I
C
C     Select a central element of the array and save it in location T
C
      IJ = I + INT((J-I)*R)
      T = DX(IJ)
      TY = DY(IJ)
C
C     If first element of array is greater than T, interchange with T
C
      IF (DX(I) .GT. T) THEN
         DX(IJ) = DX(I)
         DX(I) = T
         T = DX(IJ)
         DY(IJ) = DY(I)
         DY(I) = TY
         TY = DY(IJ)
      ENDIF
      L = J
C
C     If last element of array is less than T, interchange with T
C
      IF (DX(J) .LT. T) THEN
         DX(IJ) = DX(J)
         DX(J) = T
         T = DX(IJ)
         DY(IJ) = DY(J)
         DY(J) = TY
         TY = DY(IJ)
C
C        If first element of array is greater than T, interchange with T
C
         IF (DX(I) .GT. T) THEN
            DX(IJ) = DX(I)
            DX(I) = T
            T = DX(IJ)
            DY(IJ) = DY(I)
            DY(I) = TY
            TY = DY(IJ)
         ENDIF
      ENDIF
C
C     Find an element in the second half of the array which is smaller
C     than T
C
  130 L = L-1
      IF (DX(L) .GT. T) GO TO 130
C
C     Find an element in the first half of the array which is greater
C     than T
C
  140 K = K+1
      IF (DX(K) .LT. T) GO TO 140
C
C     Interchange these elements
C
      IF (K .LE. L) THEN
         TT = DX(L)
         DX(L) = DX(K)
         DX(K) = TT
         TTY = DY(L)
         DY(L) = DY(K)
         DY(K) = TTY
         GO TO 130
      ENDIF
C
C     Save upper and lower subscripts of the array yet to be sorted
C
      IF (L-I .GT. J-K) THEN
         IL(M) = I
         IU(M) = L
         I = K
         M = M+1
      ELSE
         IL(M) = K
         IU(M) = J
         J = L
         M = M+1
      ENDIF
      GO TO 160
C
C     Begin again on another portion of the unsorted array
C
  150 M = M-1
      IF (M .EQ. 0) GO TO 190
      I = IL(M)
      J = IU(M)
C
  160 IF (J-I .GE. 1) GO TO 120
      IF (I .EQ. 1) GO TO 110
      I = I-1
C
  170 I = I+1
      IF (I .EQ. J) GO TO 150
      T = DX(I+1)
      TY = DY(I+1)
      IF (DX(I) .LE. T) GO TO 170
      K = I
C
  180 DX(K+1) = DX(K)
      DY(K+1) = DY(K)
      K = K-1
      IF (T .LT. DX(K)) GO TO 180
      DX(K+1) = T
      DY(K+1) = TY
      GO TO 170
C
C     Clean up
C
  190 IF (KFLAG .LE. -1) THEN
         DO 200 I=1,NN
            DX(I) = -DX(I)
  200    CONTINUE
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION DSPENC (X)
C***BEGIN PROLOGUE  DSPENC
C***PURPOSE  Compute a form of Spence's integral due to K. Mitchell.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C5
C***TYPE      DOUBLE PRECISION (SPENC-S, DSPENC-D)
C***KEYWORDS  FNLIB, SPECIAL FUNCTIONS, SPENCE'S INTEGRAL
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DSPENC(X) calculates the double precision Spence's integral
C for double precision argument X.  Spence's function defined by
C        integral from 0 to X of  -LOG(1-Y)/Y  DY.
C For ABS(X) .LE. 1, the uniformly convergent expansion
C        DSPENC = sum K=1,infinity  X**K / K**2     is valid.
C This is a form of Spence's integral due to K. Mitchell which differs
C from the definition in the NBS Handbook of Mathematical Functions.
C
C Spence's function can be used to evaluate much more general integral
C forms.  For example,
C        integral from 0 to Z of  LOG(A*X+B)/(C*X+D)  DX  =
C             LOG(ABS(B-A*D/C))*LOG(ABS(A*(C*X+D)/(A*D-B*C)))/C
C             - DSPENC (A*(C*Z+D)/(A*D-B*C)) / C.
C
C Ref -- K. Mitchell, Philosophical Magazine, 40, p.351 (1949).
C        Stegun and Abromowitz, AMS 55, p.1004.
C
C
C Series for SPEN       on the interval  0.          to  5.00000E-01
C                                        with weighted error   4.74E-32
C                                         log weighted error  31.32
C                               significant figures required  30.37
C                                    decimal places required  32.11
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, DCSEVL, INITDS
C***REVISION HISTORY  (YYMMDD)
C   780201  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891115  Corrected third argument in reference to INITDS.  (WRB)
C   891115  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  DSPENC
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DOUBLE PRECISION X, SPENCS(38), ALN, PI26, XBIG, DCSEVL
      LOGICAL FIRST
      SAVE SPENCS, PI26, NSPENC, XBIG, FIRST
      DATA SPENCS(  1) / +.1527365598 8924058729 4668491002 8 D+0      /
      DATA SPENCS(  2) / +.8169658058 0510144035 0183818527 1 D-1      /
      DATA SPENCS(  3) / +.5814157140 7787308729 7735064118 2 D-2      /
      DATA SPENCS(  4) / +.5371619814 5415275422 4788900531 9 D-3      /
      DATA SPENCS(  5) / +.5724704675 1858262332 1060305478 2 D-4      /
      DATA SPENCS(  6) / +.6674546121 6493363436 0783543858 9 D-5      /
      DATA SPENCS(  7) / +.8276467339 7156769815 8439168901 1 D-6      /
      DATA SPENCS(  8) / +.1073315673 0306789512 7000587335 4 D-6      /
      DATA SPENCS(  9) / +.1440077294 3032394023 3459033151 3 D-7      /
      DATA SPENCS( 10) / +.1984442029 9659063678 9887713960 8 D-8      /
      DATA SPENCS( 11) / +.2794005822 1636387202 0199482161 5 D-9      /
      DATA SPENCS( 12) / +.4003991310 8833118230 7258044590 8 D-10     /
      DATA SPENCS( 13) / +.5823462892 0446384713 6813583575 7 D-11     /
      DATA SPENCS( 14) / +.8576708692 6386892780 9791477122 4 D-12     /
      DATA SPENCS( 15) / +.1276862586 2801930459 8948303343 3 D-12     /
      DATA SPENCS( 16) / +.1918826209 0425170811 6238041606 2 D-13     /
      DATA SPENCS( 17) / +.2907319206 9771381777 9579971967 3 D-14     /
      DATA SPENCS( 18) / +.4437112685 2767804625 5747364174 5 D-15     /
      DATA SPENCS( 19) / +.6815727787 4145995278 6735913560 7 D-16     /
      DATA SPENCS( 20) / +.1053017386 0155744295 4701941664 4 D-16     /
      DATA SPENCS( 21) / +.1635389806 7523771000 5182173457 0 D-17     /
      DATA SPENCS( 22) / +.2551852874 9404639323 1090164258 1 D-18     /
      DATA SPENCS( 23) / +.3999020621 9993601127 7047037951 9 D-19     /
      DATA SPENCS( 24) / +.6291501645 2168118765 1414917119 9 D-20     /
      DATA SPENCS( 25) / +.9933827435 6756776438 0388775253 3 D-21     /
      DATA SPENCS( 26) / +.1573679570 7499648167 2176380586 6 D-21     /
      DATA SPENCS( 27) / +.2500595316 8494761293 6927095466 6 D-22     /
      DATA SPENCS( 28) / +.3984740918 3838111392 1066325333 3 D-23     /
      DATA SPENCS( 29) / +.6366473210 0828438926 9132629333 3 D-24     /
      DATA SPENCS( 30) / +.1019674287 2396783670 7706197333 3 D-24     /
      DATA SPENCS( 31) / +.1636881058 9135188411 1107413333 3 D-25     /
      DATA SPENCS( 32) / +.2633310439 4176501173 4527999999 9 D-26     /
      DATA SPENCS( 33) / +.4244811560 1239768172 2436266666 6 D-27     /
      DATA SPENCS( 34) / +.6855411983 6800529168 2474666666 6 D-28     /
      DATA SPENCS( 35) / +.1109122433 4380564340 1898666666 6 D-28     /
      DATA SPENCS( 36) / +.1797431304 9998914573 6533333333 3 D-29     /
      DATA SPENCS( 37) / +.2917505845 9760951732 9066666666 6 D-30     /
      DATA SPENCS( 38) / +.4742646808 9286710613 3333333333 3 D-31     /
      DATA PI26 / +1.644934066 8482264364 7241516664 6025189219 D0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DSPENC
      IF (FIRST) THEN
         NSPENC = INITDS (SPENCS, 38, 0.1*REAL(D1MACH(3)))
         XBIG = 1.0D0/D1MACH(3)
      ENDIF
      FIRST = .FALSE.
C
      IF (X.GT.2.0D0) GO TO 60
      IF (X.GT.1.0D0) GO TO 50
      IF (X.GT.0.5D0) GO TO 40
      IF (X.GE.0.0D0) GO TO 30
      IF (X.GT.(-1.D0)) GO TO 20
C
C HERE IF X .LE. -1.0
C
      ALN = LOG(1.0D0-X)
      DSPENC = -PI26 - 0.5D0*ALN*(2.0D0*LOG(-X)-ALN)
      IF (X.GT.(-XBIG)) DSPENC = DSPENC
     1  + (1.D0 + DCSEVL (4.D0/(1.D0-X)-1.D0, SPENCS, NSPENC))/(1.D0-X)
      RETURN
C
C -1.0 .LT. X .LT. 0.0
C
 20   DSPENC = -0.5D0*LOG(1.0D0-X)**2
     1  - X*(1.D0+DCSEVL(4.D0*X/(X-1.D0)-1.D0, SPENCS, NSPENC))/(X-1.D0)
      RETURN
C
C 0.0 .LE. X .LE. 0.5
C
 30   DSPENC = X*(1.D0 + DCSEVL (4.D0*X-1.D0, SPENCS, NSPENC))
      RETURN
C
C 0.5 .LT. X .LE. 1.0
C
 40   DSPENC = PI26
      IF (X.NE.1.D0) DSPENC = PI26 - LOG(X)*LOG(1.0D0-X)
     1  - (1.D0-X)*(1.D0+DCSEVL(4.D0*(1.D0-X)-1.D0, SPENCS, NSPENC))
      RETURN
C
C 1.0 .LT. X .LE. 2.0
C
 50   DSPENC = PI26 - 0.5D0*LOG(X)*LOG((X-1.D0)**2/X)
     1  + (X-1.D0)*(1.D0+DCSEVL(4.D0*(X-1.D0)/X-1.D0, SPENCS, NSPENC))/X
      RETURN
C
C X .GT. 2.0
C
 60   DSPENC = 2.0D0*PI26 - 0.5D0*LOG(X)**2
      IF (X.LT.XBIG) DSPENC = DSPENC
     1  - (1.D0 + DCSEVL (4.D0/X-1.D0, SPENCS, NSPENC))/X
      RETURN
C
      END
      DOUBLE PRECISION FUNCTION DSUM (N, DX, INCX)
C
C     MARK VANGEL, NIST, JANUARY 1994
C     FUNCTION DSUM SUMS DX((I-1)*INCX+1), FOR I=1, ..., N.
C     COMPARE TO BLAS LEVEL 1 ROUTINE DASUM.
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION DX(1)
      DSUM = 0.D0
      DO 10 I=1, N
         DSUM = DSUM +DX ((I-1)*INCX +1)
 10   CONTINUE
      RETURN
      END
      SUBROUTINE DSVDC(X,LDX,N,P,S,E,U,LDU,V,LDV,WORK,JOB,INFO)
      INTEGER LDX,N,P,LDU,LDV,JOB,INFO
      DOUBLE PRECISION X(LDX,1),S(1),E(1),U(LDU,1),V(LDV,1),WORK(1)
C
C
C     DSVDC IS A SUBROUTINE TO REDUCE A DOUBLE PRECISION NXP MATRIX X
C     BY ORTHOGONAL TRANSFORMATIONS U AND V TO DIAGONAL FORM.  THE
C     DIAGONAL ELEMENTS S(I) ARE THE SINGULAR VALUES OF X.  THE
C     COLUMNS OF U ARE THE CORRESPONDING LEFT SINGULAR VECTORS,
C     AND THE COLUMNS OF V THE RIGHT SINGULAR VECTORS.
C
C     ON ENTRY
C
C         X         DOUBLE PRECISION(LDX,P), WHERE LDX.GE.N.
C                   X CONTAINS THE MATRIX WHOSE SINGULAR VALUE
C                   DECOMPOSITION IS TO BE COMPUTED.  X IS
C                   DESTROYED BY DSVDC.
C
C         LDX       INTEGER.
C                   LDX IS THE LEADING DIMENSION OF THE ARRAY X.
C
C         N         INTEGER.
C                   N IS THE NUMBER OF ROWS OF THE MATRIX X.
C
C         P         INTEGER.
C                   P IS THE NUMBER OF COLUMNS OF THE MATRIX X.
C
C         LDU       INTEGER.
C                   LDU IS THE LEADING DIMENSION OF THE ARRAY U.
C                   (SEE BELOW).
C
C         LDV       INTEGER.
C                   LDV IS THE LEADING DIMENSION OF THE ARRAY V.
C                   (SEE BELOW).
C
C         WORK      DOUBLE PRECISION(N).
C                   WORK IS A SCRATCH ARRAY.
C
C         JOB       INTEGER.
C                   JOB CONTROLS THE COMPUTATION OF THE SINGULAR
C                   VECTORS.  IT HAS THE DECIMAL EXPANSION AB
C                   WITH THE FOLLOWING MEANING
C
C                        A.EQ.0    DO NOT COMPUTE THE LEFT SINGULAR
C                                  VECTORS.
C                        A.EQ.1    RETURN THE N LEFT SINGULAR VECTORS
C                                  IN U.
C                        A.GE.2    RETURN THE FIRST MIN(N,P) SINGULAR
C                                  VECTORS IN U.
C                        B.EQ.0    DO NOT COMPUTE THE RIGHT SINGULAR
C                                  VECTORS.
C                        B.EQ.1    RETURN THE RIGHT SINGULAR VECTORS
C                                  IN V.
C
C     ON RETURN
C
C         S         DOUBLE PRECISION(MM), WHERE MM=MIN(N+1,P).
C                   THE FIRST MIN(N,P) ENTRIES OF S CONTAIN THE
C                   SINGULAR VALUES OF X ARRANGED IN DESCENDING
C                   ORDER OF MAGNITUDE.
C
C         E         DOUBLE PRECISION(P),
C                   E ORDINARILY CONTAINS ZEROS.  HOWEVER SEE THE
C                   DISCUSSION OF INFO FOR EXCEPTIONS.
C
C         U         DOUBLE PRECISION(LDU,K), WHERE LDU.GE.N.  IF
C                                   JOBA.EQ.1 THEN K.EQ.N, IF JOBA.GE.2
C                                   THEN K.EQ.MIN(N,P).
C                   U CONTAINS THE MATRIX OF LEFT SINGULAR VECTORS.
C                   U IS NOT REFERENCED IF JOBA.EQ.0.  IF N.LE.P
C                   OR IF JOBA.EQ.2, THEN U MAY BE IDENTIFIED WITH X
C                   IN THE SUBROUTINE CALL.
C
C         V         DOUBLE PRECISION(LDV,P), WHERE LDV.GE.P.
C                   V CONTAINS THE MATRIX OF RIGHT SINGULAR VECTORS.
C                   V IS NOT REFERENCED IF JOB.EQ.0.  IF P.LE.N,
C                   THEN V MAY BE IDENTIFIED WITH X IN THE
C                   SUBROUTINE CALL.
C
C         INFO      INTEGER.
C                   THE SINGULAR VALUES (AND THEIR CORRESPONDING
C                   SINGULAR VECTORS) S(INFO+1),S(INFO+2),...,S(M)
C                   ARE CORRECT (HERE M=MIN(N,P)).  THUS IF
C                   INFO.EQ.0, ALL THE SINGULAR VALUES AND THEIR
C                   VECTORS ARE CORRECT.  IN ANY EVENT, THE MATRIX
C                   B = TRANS(U)*X*V IS THE BIDIAGONAL MATRIX
C                   WITH THE ELEMENTS OF S ON ITS DIAGONAL AND THE
C                   ELEMENTS OF E ON ITS SUPER-DIAGONAL (TRANS(U)
C                   IS THE TRANSPOSE OF U).  THUS THE SINGULAR
C                   VALUES OF X AND B ARE THE SAME.
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C              CORRECTION MADE TO SHIFT 2/84.
C     G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
C
C     DSVDC USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS.
C
C     EXTERNAL DROT
C     BLAS DAXPY,DDOT,DSCAL,DSWAP,DNRM2,DROTG
C     FORTRAN DABS,DMAX1,MAX0,MIN0,MOD,DSQRT
C
C     INTERNAL VARIABLES
C
      INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT,
     *        MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1
      DOUBLE PRECISION DDOT,T
      DOUBLE PRECISION B,C,CS,EL,EMM1,F,G,DNRM2,SCALE,SHIFT,SL,SM,SN,
     *                 SMM1,T1,TEST,ZTEST
      LOGICAL WANTU,WANTV
C
C
C     SET THE MAXIMUM NUMBER OF ITERATIONS.
C
      MAXIT = 30
C
C     DETERMINE WHAT IS TO BE COMPUTED.
C
      WANTU = .FALSE.
      WANTV = .FALSE.
      JOBU = MOD(JOB,100)/10
      NCU = N
      IF (JOBU .GT. 1) NCU = MIN0(N,P)
      IF (JOBU .NE. 0) WANTU = .TRUE.
      IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE.
C
C     REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS
C     IN S AND THE SUPER-DIAGONAL ELEMENTS IN E.
C
      INFO = 0
      NCT = MIN0(N-1,P)
      NRT = MAX0(0,MIN0(P-2,N))
      LU = MAX0(NCT,NRT)
      IF (LU .LT. 1) GO TO 170
      DO 160 L = 1, LU
         LP1 = L + 1
         IF (L .GT. NCT) GO TO 20
C
C           COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND
C           PLACE THE L-TH DIAGONAL IN S(L).
C
            S(L) = DNRM2(N-L+1,X(L,L),1)
            IF (S(L) .EQ. 0.0D0) GO TO 10
               IF (X(L,L) .NE. 0.0D0) S(L) = DSIGN(S(L),X(L,L))
               CALL DSCAL(N-L+1,1.0D0/S(L),X(L,L),1)
               X(L,L) = 1.0D0 + X(L,L)
   10       CONTINUE
            S(L) = -S(L)
   20    CONTINUE
         IF (P .LT. LP1) GO TO 50
         DO 40 J = LP1, P
            IF (L .GT. NCT) GO TO 30
            IF (S(L) .EQ. 0.0D0) GO TO 30
C
C              APPLY THE TRANSFORMATION.
C
               T = -DDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L)
               CALL DAXPY(N-L+1,T,X(L,L),1,X(L,J),1)
   30       CONTINUE
C
C           PLACE THE L-TH ROW OF X INTO  E FOR THE
C           SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION.
C
            E(J) = X(L,J)
   40    CONTINUE
   50    CONTINUE
         IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 70
C
C           PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK
C           MULTIPLICATION.
C
            DO 60 I = L, N
               U(I,L) = X(I,L)
   60       CONTINUE
   70    CONTINUE
         IF (L .GT. NRT) GO TO 150
C
C           COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE
C           L-TH SUPER-DIAGONAL IN E(L).
C
            E(L) = DNRM2(P-L,E(LP1),1)
            IF (E(L) .EQ. 0.0D0) GO TO 80
               IF (E(LP1) .NE. 0.0D0) E(L) = DSIGN(E(L),E(LP1))
               CALL DSCAL(P-L,1.0D0/E(L),E(LP1),1)
               E(LP1) = 1.0D0 + E(LP1)
   80       CONTINUE
            E(L) = -E(L)
            IF (LP1 .GT. N .OR. E(L) .EQ. 0.0D0) GO TO 120
C
C              APPLY THE TRANSFORMATION.
C
               DO 90 I = LP1, N
                  WORK(I) = 0.0D0
   90          CONTINUE
               DO 100 J = LP1, P
                  CALL DAXPY(N-L,E(J),X(LP1,J),1,WORK(LP1),1)
  100          CONTINUE
               DO 110 J = LP1, P
                  CALL DAXPY(N-L,-E(J)/E(LP1),WORK(LP1),1,X(LP1,J),1)
  110          CONTINUE
  120       CONTINUE
            IF (.NOT.WANTV) GO TO 140
C
C              PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT
C              BACK MULTIPLICATION.
C
               DO 130 I = LP1, P
                  V(I,L) = E(I)
  130          CONTINUE
  140       CONTINUE
  150    CONTINUE
  160 CONTINUE
  170 CONTINUE
C
C     SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M.
C
      M = MIN0(P,N+1)
      NCTP1 = NCT + 1
      NRTP1 = NRT + 1
      IF (NCT .LT. P) S(NCTP1) = X(NCTP1,NCTP1)
      IF (N .LT. M) S(M) = 0.0D0
      IF (NRTP1 .LT. M) E(NRTP1) = X(NRTP1,M)
      E(M) = 0.0D0
C
C     IF REQUIRED, GENERATE U.
C
      IF (.NOT.WANTU) GO TO 300
         IF (NCU .LT. NCTP1) GO TO 200
         DO 190 J = NCTP1, NCU
            DO 180 I = 1, N
               U(I,J) = 0.0D0
  180       CONTINUE
            U(J,J) = 1.0D0
  190    CONTINUE
  200    CONTINUE
         IF (NCT .LT. 1) GO TO 290
         DO 280 LL = 1, NCT
            L = NCT - LL + 1
            IF (S(L) .EQ. 0.0D0) GO TO 250
               LP1 = L + 1
               IF (NCU .LT. LP1) GO TO 220
               DO 210 J = LP1, NCU
                  T = -DDOT(N-L+1,U(L,L),1,U(L,J),1)/U(L,L)
                  CALL DAXPY(N-L+1,T,U(L,L),1,U(L,J),1)
  210          CONTINUE
  220          CONTINUE
               CALL DSCAL(N-L+1,-1.0D0,U(L,L),1)
               U(L,L) = 1.0D0 + U(L,L)
               LM1 = L - 1
               IF (LM1 .LT. 1) GO TO 240
               DO 230 I = 1, LM1
                  U(I,L) = 0.0D0
  230          CONTINUE
  240          CONTINUE
            GO TO 270
  250       CONTINUE
               DO 260 I = 1, N
                  U(I,L) = 0.0D0
  260          CONTINUE
               U(L,L) = 1.0D0
  270       CONTINUE
  280    CONTINUE
  290    CONTINUE
  300 CONTINUE
C
C     IF IT IS REQUIRED, GENERATE V.
C
      IF (.NOT.WANTV) GO TO 350
         DO 340 LL = 1, P
            L = P - LL + 1
            LP1 = L + 1
            IF (L .GT. NRT) GO TO 320
            IF (E(L) .EQ. 0.0D0) GO TO 320
               DO 310 J = LP1, P
                  T = -DDOT(P-L,V(LP1,L),1,V(LP1,J),1)/V(LP1,L)
                  CALL DAXPY(P-L,T,V(LP1,L),1,V(LP1,J),1)
  310          CONTINUE
  320       CONTINUE
            DO 330 I = 1, P
               V(I,L) = 0.0D0
  330       CONTINUE
            V(L,L) = 1.0D0
  340    CONTINUE
  350 CONTINUE
C
C     MAIN ITERATION LOOP FOR THE SINGULAR VALUES.
C
      MM = M
      ITER = 0
  360 CONTINUE
C
C        QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND.
C
C     ...EXIT
         IF (M .EQ. 0) GO TO 620
C
C        IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET
C        FLAG AND RETURN.
C
         IF (ITER .LT. MAXIT) GO TO 370
            INFO = M
C     ......EXIT
            GO TO 620
  370    CONTINUE
C
C        THIS SECTION OF THE PROGRAM INSPECTS FOR
C        NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS.  ON
C        COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS.
C
C           KASE = 1     IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M
C           KASE = 2     IF S(L) IS NEGLIGIBLE AND L.LT.M
C           KASE = 3     IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND
C                        S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP).
C           KASE = 4     IF E(M-1) IS NEGLIGIBLE (CONVERGENCE).
C
         DO 390 LL = 1, M
            L = M - LL
C        ...EXIT
            IF (L .EQ. 0) GO TO 400
            TEST = DABS(S(L)) + DABS(S(L+1))
            ZTEST = TEST + DABS(E(L))
            IF (ZTEST .NE. TEST) GO TO 380
               E(L) = 0.0D0
C        ......EXIT
               GO TO 400
  380       CONTINUE
  390    CONTINUE
  400    CONTINUE
         IF (L .NE. M - 1) GO TO 410
            KASE = 4
         GO TO 480
  410    CONTINUE
            LP1 = L + 1
            MP1 = M + 1
            DO 430 LLS = LP1, MP1
               LS = M - LLS + LP1
C           ...EXIT
               IF (LS .EQ. L) GO TO 440
               TEST = 0.0D0
               IF (LS .NE. M) TEST = TEST + DABS(E(LS))
               IF (LS .NE. L + 1) TEST = TEST + DABS(E(LS-1))
               ZTEST = TEST + DABS(S(LS))
               IF (ZTEST .NE. TEST) GO TO 420
                  S(LS) = 0.0D0
C           ......EXIT
                  GO TO 440
  420          CONTINUE
  430       CONTINUE
  440       CONTINUE
            IF (LS .NE. L) GO TO 450
               KASE = 3
            GO TO 470
  450       CONTINUE
            IF (LS .NE. M) GO TO 460
               KASE = 1
            GO TO 470
  460       CONTINUE
               KASE = 2
               L = LS
  470       CONTINUE
  480    CONTINUE
         L = L + 1
C
C        PERFORM THE TASK INDICATED BY KASE.
C
         GO TO (490,520,540,570), KASE
C
C        DEFLATE NEGLIGIBLE S(M).
C
  490    CONTINUE
            MM1 = M - 1
            F = E(M-1)
            E(M-1) = 0.0D0
            DO 510 KK = L, MM1
               K = MM1 - KK + L
               T1 = S(K)
               CALL DROTG(T1,F,CS,SN)
               S(K) = T1
               IF (K .EQ. L) GO TO 500
                  F = -SN*E(K-1)
                  E(K-1) = CS*E(K-1)
  500          CONTINUE
               IF (WANTV) CALL DROT(P,V(1,K),1,V(1,M),1,CS,SN)
  510       CONTINUE
         GO TO 610
C
C        SPLIT AT NEGLIGIBLE S(L).
C
  520    CONTINUE
            F = E(L-1)
            E(L-1) = 0.0D0
            DO 530 K = L, M
               T1 = S(K)
               CALL DROTG(T1,F,CS,SN)
               S(K) = T1
               F = -SN*E(K)
               E(K) = CS*E(K)
               IF (WANTU) CALL DROT(N,U(1,K),1,U(1,L-1),1,CS,SN)
  530       CONTINUE
         GO TO 610
C
C        PERFORM ONE QR STEP.
C
  540    CONTINUE
C
C           CALCULATE THE SHIFT.
C
            SCALE = DMAX1(DABS(S(M)),DABS(S(M-1)),DABS(E(M-1)),
     *                    DABS(S(L)),DABS(E(L)))
            SM = S(M)/SCALE
            SMM1 = S(M-1)/SCALE
            EMM1 = E(M-1)/SCALE
            SL = S(L)/SCALE
            EL = E(L)/SCALE
            B = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0D0
            C = (SM*EMM1)**2
            SHIFT = 0.0D0
            IF (B .EQ. 0.0D0 .AND. C .EQ. 0.0D0) GO TO 550
               SHIFT = DSQRT(B**2+C)
               IF (B .LT. 0.0D0) SHIFT = -SHIFT
               SHIFT = C/(B + SHIFT)
  550       CONTINUE
            F = (SL + SM)*(SL - SM) + SHIFT
            G = SL*EL
C
C           CHASE ZEROS.
C
            MM1 = M - 1
            DO 560 K = L, MM1
               CALL DROTG(F,G,CS,SN)
               IF (K .NE. L) E(K-1) = F
               F = CS*S(K) + SN*E(K)
               E(K) = CS*E(K) - SN*S(K)
               G = SN*S(K+1)
               S(K+1) = CS*S(K+1)
               IF (WANTV) CALL DROT(P,V(1,K),1,V(1,K+1),1,CS,SN)
               CALL DROTG(F,G,CS,SN)
               S(K) = F
               F = CS*E(K) + SN*S(K+1)
               S(K+1) = -SN*E(K) + CS*S(K+1)
               G = SN*E(K+1)
               E(K+1) = CS*E(K+1)
               IF (WANTU .AND. K .LT. N)
     *            CALL DROT(N,U(1,K),1,U(1,K+1),1,CS,SN)
  560       CONTINUE
            E(M-1) = F
            ITER = ITER + 1
         GO TO 610
C
C        CONVERGENCE.
C
  570    CONTINUE
C
C           MAKE THE SINGULAR VALUE  POSITIVE.
C
            IF (S(L) .GE. 0.0D0) GO TO 580
               S(L) = -S(L)
               IF (WANTV) CALL DSCAL(P,-1.0D0,V(1,L),1)
  580       CONTINUE
C
C           ORDER THE SINGULAR VALUE.
C
  590       IF (L .EQ. MM) GO TO 600
C           ...EXIT
               IF (S(L) .GE. S(L+1)) GO TO 600
               T = S(L)
               S(L) = S(L+1)
               S(L+1) = T
               IF (WANTV .AND. L .LT. P)
     *            CALL DSWAP(P,V(1,L),1,V(1,L+1),1)
               IF (WANTU .AND. L .LT. N)
     *            CALL DSWAP(N,U(1,L),1,U(1,L+1),1)
               L = L + 1
            GO TO 590
  600       CONTINUE
            ITER = 0
            M = M - 1
  610    CONTINUE
      GO TO 360
  620 CONTINUE
      RETURN
      END
      SUBROUTINE DSWAP (N,DX,INCX,DY,INCY)
C
C     INTERCHANGES TWO VECTORS.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(1),DY(1),DTEMP
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C       CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL
C         TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DTEMP = DX(IX)
        DX(IX) = DY(IY)
        DY(IY) = DTEMP
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C       CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C       CLEAN-UP LOOP
C
   20 M = MOD(N,3)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DTEMP = DX(I)
        DX(I) = DY(I)
        DY(I) = DTEMP
   30 CONTINUE
      IF( N .LT. 3 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,3
        DTEMP = DX(I)
        DX(I) = DY(I)
        DY(I) = DTEMP
        DTEMP = DX(I + 1)
        DX(I + 1) = DY(I + 1)
        DY(I + 1) = DTEMP
        DTEMP = DX(I + 2)
        DX(I + 2) = DY(I + 2)
        DY(I + 2) = DTEMP
   50 CONTINUE
      RETURN
      END
      REAL FUNCTION DUMFUN(X0)
C
C     PURPOSE--AUXILLARY FUNCTION FOR COMPUTING A USER-DEFINED
C              FUNCTION.  USED BY THE NUMERICAL DERIVATIVE ROUTINE
C              INITIALLY, BUT MAY BE APPLICABLE TO OTHER APPLICATIONS.
C              IT COMPUTES THE FUNCTION AT THE VALUE X0
C              AND RETURNS THE FUNCTION VALUE IN DUMFUN.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/1
C     ORIGINAL VERSION--JANUARY   2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      REAL X0
C
      CHARACTER*4 MODEL
      CHARACTER*4 IPARN
      CHARACTER*4 IPARN2
      CHARACTER*4 IANGLU
      CHARACTER*4 ITYPEH
      CHARACTER*4 IW21HO
      CHARACTER*4 IW22HO
      CHARACTER*4 IVARN
      CHARACTER*4 IVARN2
      CHARACTER*4 IZNAME
      CHARACTER*4 IZNAM2
      CHARACTER*4 IBUGA3
      CHARACTER*4 IBUGCO
      CHARACTER*4 IBUGEV
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      PARAMETER (IDUMCH=1000)
      PARAMETER (IDUMC2=100)
C
      DIMENSION PARAM(IDUMC2)
      DIMENSION IPARN(IDUMC2)
      DIMENSION IPARN2(IDUMC2)
      DIMENSION IVARN(IDUMC2)
      DIMENSION IVARN2(IDUMC2)
C
      DIMENSION MODEL(IDUMCH)
      DIMENSION ITYPEH(IDUMCH)
      DIMENSION IW21HO(IDUMCH)
      DIMENSION IW22HO(IDUMCH)
      DIMENSION W2HOLD(IDUMCH)
C
      DIMENSION ILOCV(IDUMC2)
C
      COMMON /DUMCMC/ IBUGA3, ITYPEH, IW21HO, IW22HO, IPARN, IPARN2, 
     &                IVARN, IVARN2, MODEL, IZNAME, IZNAM2, IZNDEX
      COMMON /DUMCMR/ PARAM, W2HOLD,
     &                NUMCHA, NUMVAR, NWHOLD, NUMDV, ILOCV
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IERROR='OFF'
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('AT THE BEGINNING OF DUMFUN--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3
   52   FORMAT('IBUGA3 = ',A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)NUMCHA,NUMDV,NUMVAR
   53   FORMAT('NUMCHA,NUMDV,NUMVAR = ',3I8)
        CALL DPWRST('XXX','BUG ')
        NMAX=NUMCHA
        IF(NMAX.GT.25)NMAX=25
        WRITE(ICOUT,54)(MODEL(J),J=1,NMAX)
   54   FORMAT('MODEL(I) = ',25A4)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,NUMVAR
          WRITE(ICOUT,56)I,PARAM(I),IPARN(I),IPARN2(I)
   56     FORMAT('I,PARAM(I),IPARN(I),IPARN2(I) = ',I8,E15.7,A4,A4)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
        DO59I=1,NUMDV
          WRITE(ICOUT,61)I,IVARN(I),IVARN2(I)
   61     FORMAT('I, IVARN(I),IVARN2(I) = ',I8,2X,A4,A4)
          CALL DPWRST('XXX','BUG ')
   59   CONTINUE
        WRITE(ICOUT,69)X0
   69   FORMAT('X0 = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               ***************************
C               **  STEP 3--             **
C               **  INITIALIZE PARAMETERS**
C               ***************************
C
      ISTEPN='3'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IPASS=2
      IBUGCO=IBUGA3
      IBUGEV=IBUGA3
      FX=0.0
C
      PARAM(IZNDEX)=X0
      CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMVAR,
     1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,FX,
     1IBUGCO,IBUGEV,IERROR)
      DUMFUN=FX
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,9101)FX
        CALL DPWRST('XXX','BUG ')
        DO9102KK=1,NUMDV
        WRITE(ICOUT,9103)KK,PARAM(KK)
        CALL DPWRST('XXX','BUG ')
 9102   CONTINUE
      ENDIF
 9101 FORMAT('FX  = ',E15.7)
 9103 FORMAT('I,PARAM(I) = ',I5,1X,E15.7)
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END      OF DUMFUN--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9021)FX,IERROR
 9021   FORMAT('FX,IERROR = ',G15.7,A4)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE DUNRAN(N,NPAR,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE DISCRETE UNIFORM DISTRIBUTION
C              WITH INTEGER 'NUMBER OF ITEMS' = NPAR
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --NPAR   = THE INTEGER VALUE
C                                OF THE 'NUMBER OF ITEMS' PARAMETER.
C                                NPAR SHOULD BE A POSITIVE INTEGER.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE DISCRETE UNIFORM DISTRIBUTION
C             WITH 'NUMBER OF ITEMS' PARAMETER = NPAR.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --NPAR SHOULD BE A POSITIVE INTEGER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT
C              FROM THIS DISCRETE RANDOM NUMBER
C              GENERATOR MUST NECESSARILY BE A
C              SEQUENCE OF ***INTEGER*** VALUES,
C              THE OUTPUT VECTOR X IS SINGLE
C              PRECISION IN MODE.
C              X HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL OUTPUT VECTORS FROM ALL
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION.
C              THIS CONVENTION IS BASED ON THE BELIEF THAT
C              1) A MIXTURE OF MODES (FLOATING POINT
C              VERSUS INTEGER) IS INCONSISTENT AND
C              AN UNNECESSARY COMPLICATION
C              IN A DATA ANALYSIS; AND
C              2) FLOATING POINT MACHINE ARITHMETIC
C              (AS OPPOSED TO INTEGER ARITHMETIC)
C              IS THE MORE NATURAL MODE FOR DOING
C              DATA ANALYSIS.
C     REFERENCE--JOHNSON AND KOTZ
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89/1
C     ORIGINAL VERSION--DECEMBER  1988.
C     UPDATED         --JUNE      2005. ROUTINE WAS GENERATING RANDOM
C                                       NUMBERS FROM 1 TO N RATHER
C                                       THAN 0 TO N.  CORRECTED TO
C                                       GENERATE FROM 0 TO N.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
    5   FORMAT('***** ERROR--THE REQUESTED NUMBER OF DISCRETE ',
     1         'UNIFORM RANDOM NUMBERS IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(NPAR.LT.1)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE SHAPE PARAMETER (N) FOR THE DISCRETE',
     1         'UNIFORM RANDOM NUMBERS IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)NPAR
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C     GENERATE N UNIFORM (0,1) (CONTINOUS) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     CONVERT THE N CONTINUOUS UNIFORM RANDOM NUMBERS OVER [0,1]
C     TO N DISCRETE UNIFORM RANDOM NUMBERS OVER [0,NPAR]
C
CCCCC JUNE 2005. GENERATE OVER [0,NPAR] RATHER THAN [1,NPAR].  USE
CCCCC CURRENT ALGORITHM FOR [1,NPAR+1] THEN SUBTRACT 1.
C
      NPART=NPAR+1
      ANPAR=NPART
      DO1100I=1,N
        U=X(I)
        PROD=ANPAR*U
        IPROD=PROD
        IPROD=IPROD+1
        IF(IPROD.LT.1)IPROD=1
        IF(IPROD.GT.NPART)IPROD=NPART
        X(I)=IPROD - 1
 1100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE DUNRA2(N,NPAR,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE DISCRETE UNIFORM DISTRIBUTION
C              WITH INTEGER 'NUMBER OF ITEMS' = NPAR
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --NPAR   = THE INTEGER VALUE
C                                OF THE 'NUMBER OF ITEMS' PARAMETER.
C                                NPAR SHOULD BE A POSITIVE INTEGER.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE DISCRETE UNIFORM DISTRIBUTION
C             WITH 'NUMBER OF ITEMS' PARAMETER = NPAR.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --NPAR SHOULD BE A POSITIVE INTEGER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT
C              FROM THIS DISCRETE RANDOM NUMBER
C              GENERATOR MUST NECESSARILY BE A
C              SEQUENCE OF ***INTEGER*** VALUES,
C              THE OUTPUT VECTOR X IS SINGLE
C              PRECISION IN MODE.
C              X HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL OUTPUT VECTORS FROM ALL
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION.
C              THIS CONVENTION IS BASED ON THE BELIEF THAT
C              1) A MIXTURE OF MODES (FLOATING POINT
C              VERSUS INTEGER) IS INCONSISTENT AND
C              AN UNNECESSARY COMPLICATION
C              IN A DATA ANALYSIS; AND
C              2) FLOATING POINT MACHINE ARITHMETIC
C              (AS OPPOSED TO INTEGER ARITHMETIC)
C              IS THE MORE NATURAL MODE FOR DOING
C              DATA ANALYSIS.
C     REFERENCE--JOHNSON AND KOTZ
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89/1
C     ORIGINAL VERSION--DECEMBER  1988.
C     UPDATED         --JUNE      2005. ROUTINE WAS GENERATING RANDOM
C                                       NUMBERS FROM 1 TO N RATHER
C                                       THAN 0 TO N.  CORRECTED TO
C                                       GENERATE FROM 0 TO N.
C     UPDATED         --AUGUST    2005. THIS IS A COPY OF THE ORIGINAL
C                                       DUNRAN THAT GOES FROM 1 TO N.
C                                       THIS VERSION OF ROUTINE USED
C                                       BY BOOTSTRAP COMMAND.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
    5   FORMAT('***** ERROR--THE REQUESTED NUMBER OF DISCRETE ',
     1         'UNIFORM RANDOM NUMBERS IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(NPAR.LT.1)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE SHAPE PARAMETER (N) FOR THE DISCRETE',
     1         'UNIFORM RANDOM NUMBERS IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)NPAR
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C     GENERATE N UNIFORM (0,1) (CONTINOUS) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     CONVERT THE N CONTINUOUS UNIFORM RANDOM NUMBERS OVER [0,1]
C     TO N DISCRETE UNIFORM RANDOM NUMBERS OVER [1,NPAR]
C
      ANPAR=NPAR
      DO1100I=1,N
      U=X(I)
      PROD=ANPAR*U
      IPROD=PROD
      IPROD=IPROD+1
      IF(IPROD.LT.1)IPROD=1
      IF(IPROD.GT.NPAR)IPROD=NPAR
      X(I)=IPROD
 1100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE DVLA(VA,X,PD)
C
C       ====================================================
C       Purpose: Compute parabolic cylinder functions Dv(x)
C                for large argument
C       Input:   x  --- Argument
C                va --- Order
C       Output:  PD --- Dv(x)
C       Routines called:
C             (1) VVLA for computing Vv(x) for large |x|
C             (2) GAMMA for computing â(x)
C                 SUBSTITUTE CMLIB DGAMMA FUNCTION
C       ====================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        PI=3.141592653589793D0           
        EPS=1.0D-12
        EP=DEXP(-.25*X*X)
        A0=DABS(X)**VA*EP
        R=1.0D0
        PD=1.0D0
        DO 10 K=1,16
           R=-0.5D0*R*(2.0*K-VA-1.0)*(2.0*K-VA-2.0)/(K*X*X)
           PD=PD+R
           IF (DABS(R/PD).LT.EPS) GO TO 15
10      CONTINUE
15      PD=A0*PD
        IF (X.LT.0.0D0) THEN
            X1=-X
            CALL VVLA(VA,X1,VL)
CCCCC       CALL GAMMA(-VA,GL)
            GL=DGAMMA(-VA)
            PD=PI*VL/GL+DCOS(PI*VA)*PD
        ENDIF
        RETURN
        END
      SUBROUTINE DVSA(VA,X,PD)
C
C       ===================================================
C       Purpose: Compute parabolic cylinder function Dv(x)
C                for small argument
C       Input:   x  --- Argument
C                va --- Order
C       Output:  PD --- Dv(x)
C       Routine called: GAMMA for computing â(x)
C                SUBSTITUTE CMLIB DGAMMA FUNCTION
C       ===================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        EPS=1.0D-15
        PI=3.141592653589793D0
        SQ2=DSQRT(2.0D0)
        EP=DEXP(-.25D0*X*X)
        VA0=0.5D0*(1.0D0-VA)
        IF (VA.EQ.0.0) THEN
           PD=EP
        ELSE
           IF (X.EQ.0.0) THEN
              IF (VA0.LE.0.0.AND.VA0.EQ.INT(VA0)) THEN
                 PD=0.0D0
              ELSE
CCCCC            CALL GAMMA(VA0,GA0)
                 GA0=DGAMMA(VA0)
                 PD=DSQRT(PI)/(2.0D0**(-.5D0*VA)*GA0)
              ENDIF
           ELSE
CCCCC         CALL GAMMA(-VA,G1)
              G1=DGAMMA(-VA)
              A0=2.0D0**(-0.5D0*VA-1.0D0)*EP/G1
              VT=-.5D0*VA
CCCCC         CALL GAMMA(VT,G0)
              G0=DGAMMA(VT)
              PD=G0
              R=1.0D0
              DO 10 M=1,250
                 VM=.5D0*(M-VA)
CCCCC            CALL GAMMA(VM,GM)
                 GM=DGAMMA(VM)
                 R=-R*SQ2*X/M
                 R1=GM*R
                 PD=PD+R1
                 IF (DABS(R1).LT.DABS(PD)*EPS) GO TO 15
10            CONTINUE
15            PD=A0*PD
           ENDIF
        ENDIF
        RETURN
        END
      SUBROUTINE DWECDF(X,GAMMA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE DOUBLE WEIBULL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE DOUBLE WEIBULL DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL REAL X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X) = (C/2)*X*EXP(-ABS(X)**C)
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE CDF FOR THE DOUBLE WEIBULL DISTRIBUTION
C             WITH TAIL LENGHT PARAMETER = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, CHAPTER 21
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--95/10
C     ORIGINAL VERSION--OCTOBER   1995.
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.LE.0)GOTO50
      GOTO90
   50 WRITE(ICOUT,15)
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'DWECDF SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)GAMMA
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   90 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS REWRITTEN      JANUARY 1994
      MINMAX=1
      IF(X.EQ.0.0)THEN
        CDF=0.5
      ELSEIF(X.GT.0.0)THEN
        CALL WEICDF(X,GAMMA,MINMAX,CDF2)
        CDF=0.5+CDF2/2.0
      ELSE
        ARG1=-X
        CALL WEICDF(ARG1,GAMMA,MINMAX,CDF2)
        CDF=0.5-CDF2/2.0
      ENDIF
C
      RETURN
      END
      SUBROUTINE DWEPDF(X,GAMMA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE DOUBLE WEIBULL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE DOUBLE WEIBULL DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL REAL X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X) = (C/2)*X*EXP(-ABS(X)**C)
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE DOUBLE WEIBULL DISTRIBUTION
C             WITH TAIL LENGHT PARAMETER = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, CHAPTER 21
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--95/10
C     ORIGINAL VERSION--OCTOBER   1995.
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.LE.0)GOTO50
      GOTO90
   50 WRITE(ICOUT,15)
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'DWEPDF SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)GAMMA
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      CALL DPWRST('XXX','BUG ')
      PDF=0.0
      RETURN
   90 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS REWRITTEN      JANUARY 1994
      MINMAX=1
      ARG1=ABS(X)
      CALL WEIPDF(ARG1,GAMMA,MINMAX,PDF2)
      PDF=PDF2/2.0
C
      RETURN
      END
      SUBROUTINE DWEPPF(P,GAMMA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE DOUBLE WEIBULL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE DOUBLE WEIBULL DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL REAL X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X) = (C/2)*X*EXP(-ABS(X)**C)
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (INCLUSIVELY)
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION .
C             VALUE PPF FOR THE WEIBULL DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--GAMMA SHOULD BE POSITIVE.
C                 --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, CHAPTER 21
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--95/10
C     ORIGINAL VERSION--OCTOBER   1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0.OR.P.GE.1.0)GOTO50
      IF(GAMMA.LE.0.0)GOTO55
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   55 WRITE(ICOUT,15)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)GAMMA
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'DWEPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'DWEPPF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      MINMAX=1
      IF(P.EQ.0.5)THEN
        PPF=0.0
      ELSEIF(P.LT.0.5)THEN
        ARG1=2.0*(0.5-P)
        CALL WEIPPF(ARG1,GAMMA,MINMAX,PPF)
        PPF=-PPF
      ELSE
        ARG1=2.0*(P-0.5)
        CALL WEIPPF(ARG1,GAMMA,MINMAX,PPF)
      ENDIF
C
      RETURN
      END
      SUBROUTINE DWERAN(N,GAMMA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE DOUBLE WEIBULL DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE OF THE
C                                TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE DOUBLE WEIBULL DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NON E.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--XX
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 2ND. ED., 1994.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2001.9
C     ORIGINAL VERSION--SEPTEMBER 2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'DWERAN SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'DWERAN SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N DOUBLE WEIBULL DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL DWEPPF(X(I),GAMMA,XTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE DXADD (X, IX, Y, IY, Z, IZ, IERROR)
C***BEGIN PROLOGUE  DXADD
C***PURPOSE  To provide double-precision floating-point arithmetic
C            with an extended exponent range.
C***LIBRARY   SLATEC
C***CATEGORY  A3D
C***TYPE      DOUBLE PRECISION (XADD-S, DXADD-D)
C***KEYWORDS  EXTENDED-RANGE DOUBLE-PRECISION ARITHMETIC
C***AUTHOR  Lozier, Daniel W., (National Bureau of Standards)
C           Smith, John M., (NBS and George Mason University)
C***DESCRIPTION
C     DOUBLE PRECISION X, Y, Z
C     INTEGER IX, IY, IZ
C
C                  FORMS THE EXTENDED-RANGE SUM  (Z,IZ) =
C                  (X,IX) + (Y,IY).  (Z,IZ) IS ADJUSTED
C                  BEFORE RETURNING. THE INPUT OPERANDS
C                  NEED NOT BE IN ADJUSTED FORM, BUT THEIR
C                  PRINCIPAL PARTS MUST SATISFY
C                  RADIX**(-2L).LE.ABS(X).LE.RADIX**(2L),
C                  RADIX**(-2L).LE.ABS(Y).LE.RADIX**(2L).
C
C***SEE ALSO  DXSET
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DXADJ
C***COMMON BLOCKS    DXBLK2
C***REVISION HISTORY  (YYMMDD)
C   820712  DATE WRITTEN
C   881020  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Changed all specific intrinsics to generic.  (WRB)
C           Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  DXADD
      DOUBLE PRECISION X, Y, Z
      INTEGER IX, IY, IZ
      DOUBLE PRECISION RADIX, RADIXL, RAD2L, DLG10R
      INTEGER L, L2, KMAX
      COMMON /DXBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX
      SAVE /DXBLK2/
      DOUBLE PRECISION S, T
C
C   THE CONDITIONS IMPOSED ON L AND KMAX BY THIS SUBROUTINE
C ARE
C     (1) 1 .LT. L .LE. 0.5D0*LOGR(0.5D0*DZERO)
C
C     (2) NRADPL .LT. L .LE. KMAX/6
C
C     (3) KMAX .LE. (2**NBITS - 4*L - 1)/2
C
C THESE CONDITIONS MUST BE MET BY APPROPRIATE CODING
C IN SUBROUTINE DXSET.
C
C***FIRST EXECUTABLE STATEMENT  DXADD
      IERROR=0
      IF (X.NE.0.0D0) GO TO 10
      Z = Y
      IZ = IY
      GO TO 220
   10 IF (Y.NE.0.0D0) GO TO 20
      Z = X
      IZ = IX
      GO TO 220
   20 CONTINUE
      IF (IX.GE.0 .AND. IY.GE.0) GO TO 40
      IF (IX.LT.0 .AND. IY.LT.0) GO TO 40
      IF (ABS(IX).LE.6*L .AND. ABS(IY).LE.6*L) GO TO 40
      IF (IX.GE.0) GO TO 30
      Z = Y
      IZ = IY
      GO TO 220
   30 CONTINUE
      Z = X
      IZ = IX
      GO TO 220
   40 I = IX - IY
      IF (I) 80, 50, 90
   50 IF (ABS(X).GT.1.0D0 .AND. ABS(Y).GT.1.0D0) GO TO 60
      IF (ABS(X).LT.1.0D0 .AND. ABS(Y).LT.1.0D0) GO TO 70
      Z = X + Y
      IZ = IX
      GO TO 220
   60 S = X/RADIXL
      T = Y/RADIXL
      Z = S + T
      IZ = IX + L
      GO TO 220
   70 S = X*RADIXL
      T = Y*RADIXL
      Z = S + T
      IZ = IX - L
      GO TO 220
   80 S = Y
      IS = IY
      T = X
      GO TO 100
   90 S = X
      IS = IX
      T = Y
  100 CONTINUE
C
C  AT THIS POINT, THE ONE OF (X,IX) OR (Y,IY) THAT HAS THE
C LARGER AUXILIARY INDEX IS STORED IN (S,IS). THE PRINCIPAL
C PART OF THE OTHER INPUT IS STORED IN T.
C
      I1 = ABS(I)/L
      I2 = MOD(ABS(I),L)
      IF (ABS(T).GE.RADIXL) GO TO 130
      IF (ABS(T).GE.1.0D0) GO TO 120
      IF (RADIXL*ABS(T).GE.1.0D0) GO TO 110
      J = I1 + 1
      T = T*RADIX**(L-I2)
      GO TO 140
  110 J = I1
      T = T*RADIX**(-I2)
      GO TO 140
  120 J = I1 - 1
      IF (J.LT.0) GO TO 110
      T = T*RADIX**(-I2)/RADIXL
      GO TO 140
  130 J = I1 - 2
      IF (J.LT.0) GO TO 120
      T = T*RADIX**(-I2)/RAD2L
  140 CONTINUE
C
C  AT THIS POINT, SOME OR ALL OF THE DIFFERENCE IN THE
C AUXILIARY INDICES HAS BEEN USED TO EFFECT A LEFT SHIFT
C OF T.  THE SHIFTED VALUE OF T SATISFIES
C
C       RADIX**(-2*L) .LE. ABS(T) .LE. 1.0D0
C
C AND, IF J=0, NO FURTHER SHIFTING REMAINS TO BE DONE.
C
      IF (J.EQ.0) GO TO 190
      IF (ABS(S).GE.RADIXL .OR. J.GT.3) GO TO 150
      IF (ABS(S).GE.1.0D0) GO TO (180, 150, 150), J
      IF (RADIXL*ABS(S).GE.1.0D0) GO TO (180, 170, 150), J
      GO TO (180, 170, 160), J
  150 Z = S
      IZ = IS
      GO TO 220
  160 S = S*RADIXL
  170 S = S*RADIXL
  180 S = S*RADIXL
  190 CONTINUE
C
C   AT THIS POINT, THE REMAINING DIFFERENCE IN THE
C AUXILIARY INDICES HAS BEEN USED TO EFFECT A RIGHT SHIFT
C OF S.  IF THE SHIFTED VALUE OF S WOULD HAVE EXCEEDED
C RADIX**L, THEN (S,IS) IS RETURNED AS THE VALUE OF THE
C SUM.
C
      IF (ABS(S).GT.1.0D0 .AND. ABS(T).GT.1.0D0) GO TO 200
      IF (ABS(S).LT.1.0D0 .AND. ABS(T).LT.1.0D0) GO TO 210
      Z = S + T
      IZ = IS - J*L
      GO TO 220
  200 S = S/RADIXL
      T = T/RADIXL
      Z = S + T
      IZ = IS - J*L + L
      GO TO 220
  210 S = S*RADIXL
      T = T*RADIXL
      Z = S + T
      IZ = IS - J*L - L
  220 CALL DXADJ(Z, IZ,IERROR)
      RETURN
      END
      SUBROUTINE DXADJ (X, IX, IERROR)
C***BEGIN PROLOGUE  DXADJ
C***PURPOSE  To provide double-precision floating-point arithmetic
C            with an extended exponent range.
C***LIBRARY   SLATEC
C***CATEGORY  A3D
C***TYPE      DOUBLE PRECISION (XADJ-S, DXADJ-D)
C***KEYWORDS  EXTENDED-RANGE DOUBLE-PRECISION ARITHMETIC
C***AUTHOR  Lozier, Daniel W., (National Bureau of Standards)
C           Smith, John M., (NBS and George Mason University)
C***DESCRIPTION
C     DOUBLE PRECISION X
C     INTEGER IX
C
C                  TRANSFORMS (X,IX) SO THAT
C                  RADIX**(-L) .LE. ABS(X) .LT. RADIX**L.
C                  ON MOST COMPUTERS THIS TRANSFORMATION DOES
C                  NOT CHANGE THE MANTISSA OF X PROVIDED RADIX IS
C                  THE NUMBER BASE OF DOUBLE-PRECISION ARITHMETIC.
C
C***SEE ALSO  DXSET
C***REFERENCES  (NONE)
C***ROUTINES CALLED  XERMSG
C***COMMON BLOCKS    DXBLK2
C***REVISION HISTORY  (YYMMDD)
C   820712  DATE WRITTEN
C   881020  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Changed all specific intrinsics to generic.  (WRB)
C           Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C           CALLs to XERROR changed to CALLs to XERMSG.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  DXADJ
      DOUBLE PRECISION X
      INTEGER IX
      DOUBLE PRECISION RADIX, RADIXL, RAD2L, DLG10R
      INTEGER L, L2, KMAX
      COMMON /DXBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX
      SAVE /DXBLK2/
C
C-----COMMON----------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C   THE CONDITION IMPOSED ON L AND KMAX BY THIS SUBROUTINE
C IS
C     2*L .LE. KMAX
C
C THIS CONDITION MUST BE MET BY APPROPRIATE CODING
C IN SUBROUTINE DXSET.
C
C***FIRST EXECUTABLE STATEMENT  DXADJ
      IERROR=0
      IF (X.EQ.0.0D0) GO TO 50
      IF (ABS(X).GE.1.0D0) GO TO 20
      IF (RADIXL*ABS(X).GE.1.0D0) GO TO 60
      X = X*RAD2L
      IF (IX.LT.0) GO TO 10
      IX = IX - L2
      GO TO 70
   10 IF (IX.LT.-KMAX+L2) GO TO 40
      IX = IX - L2
      GO TO 70
   20 IF (ABS(X).LT.RADIXL) GO TO 60
      X = X/RAD2L
      IF (IX.GT.0) GO TO 30
      IX = IX + L2
      GO TO 70
   30 IF (IX.GT.KMAX-L2) GO TO 40
      IX = IX + L2
      GO TO 70
   40 CONTINUE
CCC40 CALL XERMSG ('SLATEC', 'DXADJ', 'overflow in auxiliary index',
CCCCC+             207, 1)
      IERROR=207
      WRITE(ICOUT,901)
      CALL DPWRST('XXX','BUG ')
  901 FORMAT('***** ERROR FROM DXADJ, OVERFLOW IN AUXILIARY INDEX.')
      RETURN
   50 IX = 0
   60 IF (ABS(IX).GT.KMAX) GO TO 40
   70 RETURN
      END
      SUBROUTINE DXLEGF (DNU1, NUDIFF, MU1, MU2, THETA, ID, PQA, IPQA,
     1   IERROR)
C***BEGIN PROLOGUE  DXLEGF
C***PURPOSE  Compute normalized Legendre polynomials and associated
C            Legendre functions.
C***LIBRARY   SLATEC
C***CATEGORY  C3A2, C9
C***TYPE      DOUBLE PRECISION (XLEGF-S, DXLEGF-D)
C***KEYWORDS  LEGENDRE FUNCTIONS
C***AUTHOR  Smith, John M., (NBS and George Mason University)
C***DESCRIPTION
C
C   DXLEGF: Extended-range Double-precision Legendre Functions
C
C   A feature of the DXLEGF subroutine for Legendre functions is
C the use of extended-range arithmetic, a software extension of
C ordinary floating-point arithmetic that greatly increases the
C exponent range of the representable numbers. This avoids the
C need for scaling the solutions to lie within the exponent range
C of the most restrictive manufacturer's hardware. The increased
C exponent range is achieved by allocating an integer storage
C location together with each floating-point storage location.
C
C   The interpretation of the pair (X,I) where X is floating-point
C and I is integer is X*(IR**I) where IR is the internal radix of
C the computer arithmetic.
C
C   This subroutine computes one of the following vectors:
C
C 1. Legendre function of the first kind of negative order, either
C    a. P(-MU1,NU,X), P(-MU1-1,NU,X), ..., P(-MU2,NU,X) or
C    b. P(-MU,NU1,X), P(-MU,NU1+1,X), ..., P(-MU,NU2,X)
C 2. Legendre function of the second kind, either
C    a. Q(MU1,NU,X), Q(MU1+1,NU,X), ..., Q(MU2,NU,X) or
C    b. Q(MU,NU1,X), Q(MU,NU1+1,X), ..., Q(MU,NU2,X)
C 3. Legendre function of the first kind of positive order, either
C    a. P(MU1,NU,X), P(MU1+1,NU,X), ..., P(MU2,NU,X) or
C    b. P(MU,NU1,X), P(MU,NU1+1,X), ..., P(MU,NU2,X)
C 4. Normalized Legendre polynomials, either
C    a. PN(MU1,NU,X), PN(MU1+1,NU,X), ..., PN(MU2,NU,X) or
C    b. PN(MU,NU1,X), PN(MU,NU1+1,X), ..., PN(MU,NU2,X)
C
C where X = COS(THETA).
C
C   The input values to DXLEGF are DNU1, NUDIFF, MU1, MU2, THETA,
C and ID. These must satisfy
C
C    DNU1 is DOUBLE PRECISION and greater than or equal to -0.5;
C    NUDIFF is INTEGER and non-negative;
C    MU1 is INTEGER and non-negative;
C    MU2 is INTEGER and greater than or equal to MU1;
C    THETA is DOUBLE PRECISION and in the half-open interval (0,PI/2];
C    ID is INTEGER and equal to 1, 2, 3 or 4;
C
C and  additionally either NUDIFF = 0 or MU2 = MU1.
C
C   If ID=1 and NUDIFF=0, a vector of type 1a above is computed
C with NU=DNU1.
C
C   If ID=1 and MU1=MU2, a vector of type 1b above is computed
C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1.
C
C   If ID=2 and NUDIFF=0, a vector of type 2a above is computed
C with NU=DNU1.
C
C   If ID=2 and MU1=MU2, a vector of type 2b above is computed
C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1.
C
C   If ID=3 and NUDIFF=0, a vector of type 3a above is computed
C with NU=DNU1.
C
C   If ID=3 and MU1=MU2, a vector of type 3b above is computed
C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1.
C
C   If ID=4 and NUDIFF=0, a vector of type 4a above is computed
C with NU=DNU1.
C
C   If ID=4 and MU1=MU2, a vector of type 4b above is computed
C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1.
C
C   In each case the vector of computed Legendre function values
C is returned in the extended-range vector (PQA(I),IPQA(I)). The
C length of this vector is either MU2-MU1+1 or NUDIFF+1.
C
C   Where possible, DXLEGF returns IPQA(I) as zero. In this case the
C value of the Legendre function is contained entirely in PQA(I),
C so it can be used in subsequent computations without further
C consideration of extended-range arithmetic. If IPQA(I) is nonzero,
C then the value of the Legendre function is not representable in
C floating-point because of underflow or overflow. The program that
C calls DXLEGF must test IPQA(I) to ensure correct usage.
C
C   IERROR is an error indicator. If no errors are detected, IERROR=0
C when control returns to the calling routine. If an error is detected,
C IERROR is returned as nonzero. The calling routine must check the
C value of IERROR.
C
C   If IERROR=210 or 211, invalid input was provided to DXLEGF.
C   If IERROR=201,202,203, or 204, invalid input was provided to DXSET.
C   If IERROR=205 or 206, an internal consistency error occurred in
C DXSET (probably due to a software malfunction in the library routine
C I1MACH).
C   If IERROR=207, an overflow or underflow of an extended-range number
C was detected in DXADJ.
C   If IERROR=208, an overflow or underflow of an extended-range number
C was detected in DXC210.
C
C***SEE ALSO  DXSET
C***REFERENCES  Olver and Smith, Associated Legendre Functions on the
C                 Cut, J Comp Phys, v 51, n 3, Sept 1983, pp 502--518.
C               Smith, Olver and Lozier, Extended-Range Arithmetic and
C                 Normalized Legendre Polynomials, ACM Trans on Math
C                 Softw, v 7, n 1, March 1981, pp 93--105.
C***ROUTINES CALLED  DXPMU, DXPMUP, DXPNRM, DXPQNU, DXQMU, DXQNU, DXRED,
C                    DXSET, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   820728  DATE WRITTEN
C   890126  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Changed all specific intrinsics to generic.  (WRB)
C           Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C           CALLs to XERROR changed to CALLs to XERMSG.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  DXLEGF
      DOUBLE PRECISION PQA,DNU1,DNU2,SX,THETA,X,PI2
      DIMENSION PQA(*),IPQA(*)
C
C-----COMMON----------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C***FIRST EXECUTABLE STATEMENT  DXLEGF
      IERROR=0
      CALL DXSET (0, 0, 0.0D0, 0,IERROR)
      IF (IERROR.NE.0) RETURN
      PI2=2.D0*ATAN(1.D0)
C
C        ZERO OUTPUT ARRAYS
C
      L=(MU2-MU1)+NUDIFF+1
      DO 290 I=1,L
      PQA(I)=0.D0
  290 IPQA(I)=0
C
C        CHECK FOR VALID INPUT VALUES
C
      IF(NUDIFF.LT.0) GO TO 400
      IF(DNU1.LT.-.5D0) GO TO 400
      IF(MU2.LT.MU1) GO TO 400
      IF(MU1.LT.0) GO TO 400
      IF(THETA.LE.0.D0.OR.THETA.GT.PI2) GO TO 420
      IF(ID.LT.1.OR.ID.GT.4) GO TO 400
      IF((MU1.NE.MU2).AND.(NUDIFF.GT.0)) GO TO 400
C
C        IF DNU1 IS NOT AN INTEGER, NORMALIZED P(MU,DNU,X)
C        CANNOT BE CALCULATED.  IF DNU1 IS AN INTEGER AND
C        MU1.GT.DNU2 THEN ALL VALUES OF P(+MU,DNU,X) AND
C        NORMALIZED P(MU,NU,X) WILL BE ZERO.
C
      DNU2=DNU1+NUDIFF
      IF((ID.EQ.3).AND.(MOD(DNU1,1.D0).NE.0.D0)) GO TO 295
      IF((ID.EQ.4).AND.(MOD(DNU1,1.D0).NE.0.D0)) GO TO 400
      IF((ID.EQ.3.OR.ID.EQ.4).AND.MU1.GT.DNU2) RETURN
  295 CONTINUE
C
      X=COS(THETA)
      SX=1.D0/SIN(THETA)
      IF(ID.EQ.2) GO TO 300
      IF(MU2-MU1.LE.0) GO TO 360
C
C        FIXED NU, VARIABLE MU
C        CALL DXPMU TO CALCULATE P(-MU1,NU,X),....,P(-MU2,NU,X)
C
      CALL DXPMU(DNU1,DNU2,MU1,MU2,THETA,X,SX,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
      GO TO 380
C
  300 IF(MU2.EQ.MU1) GO TO 320
C
C        FIXED NU, VARIABLE MU
C        CALL DXQMU TO CALCULATE Q(MU1,NU,X),....,Q(MU2,NU,X)
C
      CALL DXQMU(DNU1,DNU2,MU1,MU2,THETA,X,SX,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
      GO TO 390
C
C        FIXED MU, VARIABLE NU
C        CALL DXQNU TO CALCULATE Q(MU,DNU1,X),....,Q(MU,DNU2,X)
C
  320 CALL DXQNU(DNU1,DNU2,MU1,THETA,X,SX,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
      GO TO 390
C
C        FIXED MU, VARIABLE NU
C        CALL DXPQNU TO CALCULATE P(-MU,DNU1,X),....,P(-MU,DNU2,X)
C
  360 CALL DXPQNU(DNU1,DNU2,MU1,THETA,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
C
C        IF ID = 3, TRANSFORM P(-MU,NU,X) VECTOR INTO
C        P(MU,NU,X) VECTOR.
C
  380 IF(ID.EQ.3) CALL DXPMUP(DNU1,DNU2,MU1,MU2,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
C
C        IF ID = 4, TRANSFORM P(-MU,NU,X) VECTOR INTO
C        NORMALIZED P(MU,NU,X) VECTOR.
C
      IF(ID.EQ.4) CALL DXPNRM(DNU1,DNU2,MU1,MU2,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
C
C        PLACE RESULTS IN REDUCED FORM IF POSSIBLE
C        AND RETURN TO MAIN PROGRAM.
C
  390 DO 395 I=1,L
      CALL DXRED(PQA(I),IPQA(I),IERROR)
      IF (IERROR.NE.0) RETURN
  395 CONTINUE
      RETURN
C
C        *****     ERROR TERMINATION     *****
C
  400 CONTINUE
CCCCC CALL XERMSG ('SLATEC', 'DXLEGF',
CCCCC+             'DNU1, NUDIFF, MU1, MU2, or ID not valid', 210, 1)
      WRITE(ICOUT,901)
      CALL DPWRST('XXX','BUG ')
  901 FORMAT('***** ERROR FROM DXLEGF, INVALID INPUT ARGUMENTS.')
      IERROR=210
      RETURN
  420 CONTINUE
CCCCC CALL XERMSG ('SLATEC', 'DXLEGF', 'THETA out of range', 211, 1)
      WRITE(ICOUT,902)
      CALL DPWRST('XXX','BUG ')
  902 FORMAT('***** ERROR FROM DXLEGF, THETA OUT OF RANGE.')
      IERROR=211
      RETURN
      END
      SUBROUTINE DXNRMP (NU, MU1, MU2, DARG, MODE, DPN, IPN, ISIG,
     1   IERROR)
C***BEGIN PROLOGUE  DXNRMP
C***PURPOSE  Compute normalized Legendre polynomials.
C***LIBRARY   SLATEC
C***CATEGORY  C3A2, C9
C***TYPE      DOUBLE PRECISION (XNRMP-S, DXNRMP-D)
C***KEYWORDS  LEGENDRE FUNCTIONS
C***AUTHOR  Lozier, Daniel W., (National Bureau of Standards)
C           Smith, John M., (NBS and George Mason University)
C***DESCRIPTION
C
C        SUBROUTINE TO CALCULATE NORMALIZED LEGENDRE POLYNOMIALS
C        (XNRMP is single-precision version)
C        DXNRMP calculates normalized Legendre polynomials of varying
C        order and fixed argument and degree. The order MU and degree
C        NU are non-negative integers and the argument is real. Because
C        the algorithm requires the use of numbers outside the normal
C        machine range, this subroutine employs a special arithmetic
C        called extended-range arithmetic. See J.M. Smith, F.W.J. Olver,
C        and D.W. Lozier, Extended-Range Arithmetic and Normalized
C        Legendre Polynomials, ACM Transactions on Mathematical Soft-
C        ware, 93-105, March 1981, for a complete description of the
C        algorithm and special arithmetic. Also see program comments
C        in DXSET.
C
C        The normalized Legendre polynomials are multiples of the
C        associated Legendre polynomials of the first kind where the
C        normalizing coefficients are chosen so as to make the integral
C        from -1 to 1 of the square of each function equal to 1. See
C        E. Jahnke, F. Emde and F. Losch, Tables of Higher Functions,
C        McGraw-Hill, New York, 1960, p. 121.
C
C        The input values to DXNRMP are NU, MU1, MU2, DARG, and MODE.
C        These must satisfy
C          1. NU .GE. 0 specifies the degree of the normalized Legendre
C             polynomial that is wanted.
C          2. MU1 .GE. 0 specifies the lowest-order normalized Legendre
C             polynomial that is wanted.
C          3. MU2 .GE. MU1 specifies the highest-order normalized Leg-
C             endre polynomial that is wanted.
C         4a. MODE = 1 and -1.0D0 .LE. DARG .LE. 1.0D0 specifies that
C             Normalized Legendre(NU, MU, DARG) is wanted for MU = MU1,
C             MU1 + 1, ..., MU2.
C         4b. MODE = 2 and -3.14159... .LT. DARG .LT. 3.14159... spec-
C             ifies that Normalized Legendre(NU, MU, COS(DARG)) is
C             wanted for MU = MU1, MU1 + 1, ..., MU2.
C
C        The output of DXNRMP consists of the two vectors DPN and IPN
C        and the error estimate ISIG. The computed values are stored as
C        extended-range numbers such that
C             (DPN(1),IPN(1))=NORMALIZED LEGENDRE(NU,MU1,DX)
C             (DPN(2),IPN(2))=NORMALIZED LEGENDRE(NU,MU1+1,DX)
C                .
C                .
C             (DPN(K),IPN(K))=NORMALIZED LEGENDRE(NU,MU2,DX)
C        where K = MU2 - MU1 + 1 and DX = DARG or COS(DARG) according
C        to whether MODE = 1 or 2. Finally, ISIG is an estimate of the
C        number of decimal digits lost through rounding errors in the
C        computation. For example if DARG is accurate to 12 significant
C        decimals, then the computed function values are accurate to
C        12 - ISIG significant decimals (except in neighborhoods of
C        zeros).
C
C        The interpretation of (DPN(I),IPN(I)) is DPN(I)*(IR**IPN(I))
C        where IR is the internal radix of the computer arithmetic. When
C        IPN(I) = 0 the value of the normalized Legendre polynomial is
C        contained entirely in DPN(I) and subsequent double-precision
C        computations can be performed without further consideration of
C        extended-range arithmetic. However, if IPN(I) .NE. 0 the corre-
C        sponding value of the normalized Legendre polynomial cannot be
C        represented in double-precision because of overflow or under-
C        flow. THE USER MUST TEST IPN(I) IN HIS/HER PROGRAM. In the case
C        that IPN(I) is nonzero, the user could rewrite his/her program
C        to use extended range arithmetic.
C
C
C
C        The interpretation of (DPN(I),IPN(I)) can be changed to
C        DPN(I)*(10**IPN(I)) by calling the extended-range subroutine
C        DXCON. This should be done before printing the computed values.
C        As an example of usage, the Fortran coding
C              J = K
C              DO 20 I = 1, K
C              CALL DXCON(DPN(I), IPN(I),IERROR)
C              IF (IERROR.NE.0) RETURN
C              PRINT 10, DPN(I), IPN(I)
C           10 FORMAT(1X, D30.18 , I15)
C              IF ((IPN(I) .EQ. 0) .OR. (J .LT. K)) GO TO 20
C              J = I - 1
C           20 CONTINUE
C        will print all computed values and determine the largest J
C        such that IPN(1) = IPN(2) = ... = IPN(J) = 0. Because of the
C        change of representation caused by calling DXCON, (DPN(I),
C        IPN(I)) for I = J+1, J+2, ... cannot be used in subsequent
C        extended-range computations.
C
C        IERROR is an error indicator. If no errors are detected,
C        IERROR=0 when control returns to the calling routine. If
C        an error is detected, IERROR is returned as nonzero. The
C        calling routine must check the value of IERROR.
C
C        If IERROR=212 or 213, invalid input was provided to DXNRMP.
C        If IERROR=201,202,203, or 204, invalid input was provided
C        to DXSET.
C        If IERROR=205 or 206, an internal consistency error occurred
C        in DXSET (probably due to a software malfunction in the
C        library routine I1MACH).
C        If IERROR=207, an overflow or underflow of an extended-range
C        number was detected in DXADJ.
C        If IERROR=208, an overflow or underflow of an extended-range
C        number was detected in DXC210.
C
C***SEE ALSO  DXSET
C***REFERENCES  Smith, Olver and Lozier, Extended-Range Arithmetic and
C                 Normalized Legendre Polynomials, ACM Trans on Math
C                 Softw, v 7, n 1, March 1981, pp 93--105.
C***ROUTINES CALLED  DXADD, DXADJ, DXRED, DXSET, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   820712  DATE WRITTEN
C   890126  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Changed all specific intrinsics to generic.  (WRB)
C           Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C           CALLs to XERROR changed to CALLs to XERMSG.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  DXNRMP
      INTEGER NU, MU1, MU2, MODE, IPN, ISIG
      DOUBLE PRECISION DARG, DPN
      DIMENSION DPN(*), IPN(*)
      DOUBLE PRECISION C1,C2,P,P1,P2,P3,S,SX,T,TX,X,DK
C
C-----COMMON----------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C CALL DXSET TO INITIALIZE EXTENDED-RANGE ARITHMETIC (SEE DXSET
C LISTING FOR DETAILS)
C***FIRST EXECUTABLE STATEMENT  DXNRMP
      IERROR=0
      CALL DXSET (0, 0, 0.0D0, 0,IERROR)
      IF (IERROR.NE.0) RETURN
C
C        TEST FOR PROPER INPUT VALUES.
C
      IF (NU.LT.0) GO TO 110
      IF (MU1.LT.0) GO TO 110
      IF (MU1.GT.MU2) GO TO 110
      IF (NU.EQ.0) GO TO 90
      IF (MODE.LT.1 .OR. MODE.GT.2) GO TO 110
      GO TO (10, 20), MODE
   10 IF (ABS(DARG).GT.1.0D0) GO TO 120
      IF (ABS(DARG).EQ.1.0D0) GO TO 90
      X = DARG
      SX = SQRT((1.0D0+ABS(X))*((0.5D0-ABS(X))+0.5D0))
      TX = X/SX
      ISIG = LOG10(2.0D0*NU*(5.0D0+TX**2))
      GO TO 30
   20 IF (ABS(DARG).GT.4.0D0*ATAN(1.0D0)) GO TO 120
      IF (DARG.EQ.0.0D0) GO TO 90
      X = COS(DARG)
      SX = ABS(SIN(DARG))
      TX = X/SX
      ISIG = LOG10(2.0D0*NU*(5.0D0+ABS(DARG*TX)))
C
C        BEGIN CALCULATION
C
   30 MU = MU2
      I = MU2 - MU1 + 1
C
C        IF MU.GT.NU, NORMALIZED LEGENDRE(NU,MU,X)=0.
C
   40 IF (MU.LE.NU) GO TO 50
      DPN(I) = 0.0D0
      IPN(I) = 0
      I = I - 1
      MU = MU - 1
      IF (I .GT. 0) GO TO 40
      ISIG = 0
      GO TO 160
   50 MU = NU
C
C        P1 = 0. = NORMALIZED LEGENDRE(NU,NU+1,X)
C
      P1 = 0.0D0
      IP1 = 0
C
C        CALCULATE P2 = NORMALIZED LEGENDRE(NU,NU,X)
C
      P2 = 1.0D0
      IP2 = 0
      P3 = 0.5D0
      DK = 2.0D0
      DO 60 J=1,NU
        P3 = ((DK+1.0D0)/DK)*P3
        P2 = P2*SX
        CALL DXADJ(P2, IP2,IERROR)
        IF (IERROR.NE.0) RETURN
        DK = DK + 2.0D0
   60 CONTINUE
      P2 = P2*SQRT(P3)
      CALL DXADJ(P2, IP2,IERROR)
      IF (IERROR.NE.0) RETURN
      S = 2.0D0*TX
      T = 1.0D0/NU
      IF (MU2.LT.NU) GO TO 70
      DPN(I) = P2
      IPN(I) = IP2
      I = I - 1
      IF (I .EQ. 0) GO TO 140
C
C        RECURRENCE PROCESS
C
   70 P = MU*T
      C1 = 1.0D0/SQRT((1.0D0-P+T)*(1.0D0+P))
      C2 = S*P*C1*P2
      C1 = -SQRT((1.0D0+P+T)*(1.0D0-P))*C1*P1
      CALL DXADD(C2, IP2, C1, IP1, P, IP,IERROR)
      IF (IERROR.NE.0) RETURN
      MU = MU - 1
      IF (MU.GT.MU2) GO TO 80
C
C        STORE IN ARRAY DPN FOR RETURN TO CALLING ROUTINE.
C
      DPN(I) = P
      IPN(I) = IP
      I = I - 1
      IF (I .EQ. 0) GO TO 140
   80 P1 = P2
      IP1 = IP2
      P2 = P
      IP2 = IP
      IF (MU.LE.MU1) GO TO 140
      GO TO 70
C
C        SPECIAL CASE WHEN X=-1 OR +1, OR NU=0.
C
   90 K = MU2 - MU1 + 1
      DO 100 I=1,K
        DPN(I) = 0.0D0
        IPN(I) = 0
  100 CONTINUE
      ISIG = 0
      IF (MU1.GT.0) GO TO 160
      ISIG = 1
      DPN(1) = SQRT(NU+0.5D0)
      IPN(1) = 0
      IF (MOD(NU,2).EQ.0) GO TO 160
      IF (MODE.EQ.1 .AND. DARG.EQ.1.0D0) GO TO 160
      IF (MODE.EQ.2) GO TO 160
      DPN(1) = -DPN(1)
      GO TO 160
C
C          ERROR PRINTOUTS AND TERMINATION.
C
  110 CONTINUE
CCCCC CALL XERMSG ('SLATEC', 'DXNRMP', 'NU, MU1, MU2 or MODE not valid',
CCCCC+             212, 1)
      WRITE(ICOUT,901)
      CALL DPWRST('XXX','BUG ')
  901 FORMAT('***** ERROR FROM DXNRMP, INVALID INOUT ARGUMENTS.')
      IERROR=212
      RETURN
  120 CONTINUE
CCCCC CALL XERMSG ('SLATEC', 'DXNRMP', 'DARG out of range', 213, 1)
      WRITE(ICOUT,902)
      CALL DPWRST('XXX','BUG ')
  902 FORMAT('***** ERROR FROM DXNRMP, FIRST ARGUMENT OUT OF RANGE.')
      IERROR=213
      RETURN
C
C        RETURN TO CALLING PROGRAM
C
  140 K = MU2 - MU1 + 1
      DO 150 I=1,K
        CALL DXRED(DPN(I),IPN(I),IERROR)
        IF (IERROR.NE.0) RETURN
  150 CONTINUE
  160 RETURN
      END
      SUBROUTINE DXPMU (NU1, NU2, MU1, MU2, THETA, X, SX, ID, PQA, IPQA,
     1   IERROR)
C***BEGIN PROLOGUE  DXPMU
C***SUBSIDIARY
C***PURPOSE  To compute the values of Legendre functions for DXLEGF.
C            Method: backward mu-wise recurrence for P(-MU,NU,X) for
C            fixed nu to obtain P(-MU2,NU1,X), P(-(MU2-1),NU1,X), ...,
C            P(-MU1,NU1,X) and store in ascending mu order.
C***LIBRARY   SLATEC
C***CATEGORY  C3A2, C9
C***TYPE      DOUBLE PRECISION (XPMU-S, DXPMU-D)
C***KEYWORDS  LEGENDRE FUNCTIONS
C***AUTHOR  Smith, John M., (NBS and George Mason University)
C***ROUTINES CALLED  DXADD, DXADJ, DXPQNU
C***REVISION HISTORY  (YYMMDD)
C   820728  DATE WRITTEN
C   890126  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Changed all specific intrinsics to generic.  (WRB)
C           Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  DXPMU
      DOUBLE PRECISION PQA,NU1,NU2,P0,X,SX,THETA,X1,X2
      DIMENSION PQA(*),IPQA(*)
C
C        CALL DXPQNU TO OBTAIN P(-MU2,NU,X)
C
C***FIRST EXECUTABLE STATEMENT  DXPMU
      IERROR=0
      CALL DXPQNU(NU1,NU2,MU2,THETA,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
      P0=PQA(1)
      IP0=IPQA(1)
      MU=MU2-1
C
C        CALL DXPQNU TO OBTAIN P(-MU2-1,NU,X)
C
      CALL DXPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
      N=MU2-MU1+1
      PQA(N)=P0
      IPQA(N)=IP0
      IF(N.EQ.1) GO TO 300
      PQA(N-1)=PQA(1)
      IPQA(N-1)=IPQA(1)
      IF(N.EQ.2) GO TO 300
      J=N-2
  290 CONTINUE
C
C        BACKWARD RECURRENCE IN MU TO OBTAIN
C              P(-MU2,NU1,X),P(-(MU2-1),NU1,X),....P(-MU1,NU1,X)
C              USING
C              (NU-MU)*(NU+MU+1.)*P(-(MU+1),NU,X)=
C                2.*MU*X*SQRT((1./(1.-X**2))*P(-MU,NU,X)-P(-(MU-1),NU,X)
C
      X1=2.D0*MU*X*SX*PQA(J+1)
      X2=-(NU1-MU)*(NU1+MU+1.D0)*PQA(J+2)
      CALL DXADD(X1,IPQA(J+1),X2,IPQA(J+2),PQA(J),IPQA(J),IERROR)
      IF (IERROR.NE.0) RETURN
      CALL DXADJ(PQA(J),IPQA(J),IERROR)
      IF (IERROR.NE.0) RETURN
      IF(J.EQ.1) GO TO 300
      J=J-1
      MU=MU-1
      GO TO 290
  300 RETURN
      END
      SUBROUTINE DXPMUP (NU1, NU2, MU1, MU2, PQA, IPQA, IERROR)
C***BEGIN PROLOGUE  DXPMUP
C***SUBSIDIARY
C***PURPOSE  To compute the values of Legendre functions for DXLEGF.
C            This subroutine transforms an array of Legendre functions
C            of the first kind of negative order stored in array PQA
C            into Legendre functions of the first kind of positive
C            order stored in array PQA. The original array is destroyed.
C***LIBRARY   SLATEC
C***CATEGORY  C3A2, C9
C***TYPE      DOUBLE PRECISION (XPMUP-S, DXPMUP-D)
C***KEYWORDS  LEGENDRE FUNCTIONS
C***AUTHOR  Smith, John M., (NBS and George Mason University)
C***ROUTINES CALLED  DXADJ
C***REVISION HISTORY  (YYMMDD)
C   820728  DATE WRITTEN
C   890126  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Changed all specific intrinsics to generic.  (WRB)
C           Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  DXPMUP
      DOUBLE PRECISION DMU,NU,NU1,NU2,PQA,PROD
      DIMENSION PQA(*),IPQA(*)
C***FIRST EXECUTABLE STATEMENT  DXPMUP
      IERROR=0
      NU=NU1
      MU=MU1
      DMU=MU
      N=INT(NU2-NU1+.1D0)+(MU2-MU1)+1
      J=1
      IF(MOD(REAL(NU),1.).NE.0.) GO TO 210
  200 IF(DMU.LT.NU+1.D0) GO TO 210
      PQA(J)=0.D0
      IPQA(J)=0
      J=J+1
      IF(J.GT.N) RETURN
C        INCREMENT EITHER MU OR NU AS APPROPRIATE.
      IF(NU2-NU1.GT..5D0) NU=NU+1.D0
      IF(MU2.GT.MU1) MU=MU+1
      GO TO 200
C
C        TRANSFORM P(-MU,NU,X) TO P(MU,NU,X) USING
C        P(MU,NU,X)=(NU-MU+1)*(NU-MU+2)*...*(NU+MU)*P(-MU,NU,X)*(-1)**MU
C
  210 PROD=1.D0
      IPROD=0
      K=2*MU
      IF(K.EQ.0) GO TO 222
      DO 220 L=1,K
      PROD=PROD*(DMU-NU-L)
  220 CALL DXADJ(PROD,IPROD,IERROR)
      IF (IERROR.NE.0) RETURN
  222 CONTINUE
      DO 240 I=J,N
      IF(MU.EQ.0) GO TO 225
      PQA(I)=PQA(I)*PROD*(-1)**MU
      IPQA(I)=IPQA(I)+IPROD
      CALL DXADJ(PQA(I),IPQA(I),IERROR)
      IF (IERROR.NE.0) RETURN
  225 IF(NU2-NU1.GT..5D0) GO TO 230
      PROD=(DMU-NU)*PROD*(-DMU-NU-1.D0)
      CALL DXADJ(PROD,IPROD,IERROR)
      IF (IERROR.NE.0) RETURN
      MU=MU+1
      DMU=DMU+1.D0
      GO TO 240
  230 PROD=PROD*(-DMU-NU-1.D0)/(DMU-NU-1.D0)
      CALL DXADJ(PROD,IPROD,IERROR)
      IF (IERROR.NE.0) RETURN
      NU=NU+1.D0
  240 CONTINUE
      RETURN
      END
      SUBROUTINE DXPNRM (NU1, NU2, MU1, MU2, PQA, IPQA, IERROR)
C***BEGIN PROLOGUE  DXPNRM
C***SUBSIDIARY
C***PURPOSE  To compute the values of Legendre functions for DXLEGF.
C            This subroutine transforms an array of Legendre functions
C            of the first kind of negative order stored in array PQA
C            into normalized Legendre polynomials stored in array PQA.
C            The original array is destroyed.
C***LIBRARY   SLATEC
C***CATEGORY  C3A2, C9
C***TYPE      DOUBLE PRECISION (XPNRM-S, DXPNRM-D)
C***KEYWORDS  LEGENDRE FUNCTIONS
C***AUTHOR  Smith, John M., (NBS and George Mason University)
C***ROUTINES CALLED  DXADJ
C***REVISION HISTORY  (YYMMDD)
C   820728  DATE WRITTEN
C   890126  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Changed all specific intrinsics to generic.  (WRB)
C           Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  DXPNRM
      DOUBLE PRECISION C1,DMU,NU,NU1,NU2,PQA,PROD
      DIMENSION PQA(*),IPQA(*)
C***FIRST EXECUTABLE STATEMENT  DXPNRM
      IERROR=0
      L=(MU2-MU1)+(NU2-NU1+1.5D0)
      MU=MU1
      DMU=MU1
      NU=NU1
C
C         IF MU .GT.NU, NORM P =0.
C
      J=1
  500 IF(DMU.LE.NU) GO TO 505
      PQA(J)=0.D0
      IPQA(J)=0
      J=J+1
      IF(J.GT.L) RETURN
C
C        INCREMENT EITHER MU OR NU AS APPROPRIATE.
C
      IF(MU2.GT.MU1) DMU=DMU+1.D0
      IF(NU2-NU1.GT..5D0) NU=NU+1.D0
      GO TO 500
C
C         TRANSFORM P(-MU,NU,X) INTO NORMALIZED P(MU,NU,X) USING
C              NORM P(MU,NU,X)=
C                 SQRT((NU+.5)*FACTORIAL(NU+MU)/FACTORIAL(NU-MU))
C                              *P(-MU,NU,X)
C
  505 PROD=1.D0
      IPROD=0
      K=2*MU
      IF(K.LE.0) GO TO 520
      DO 510 I=1,K
      PROD=PROD*SQRT(NU+DMU+1.D0-I)
  510 CALL DXADJ(PROD,IPROD,IERROR)
      IF (IERROR.NE.0) RETURN
  520 DO 540 I=J,L
      C1=PROD*SQRT(NU+.5D0)
      PQA(I)=PQA(I)*C1
      IPQA(I)=IPQA(I)+IPROD
      CALL DXADJ(PQA(I),IPQA(I),IERROR)
      IF (IERROR.NE.0) RETURN
      IF(NU2-NU1.GT..5D0) GO TO 530
      IF(DMU.GE.NU) GO TO 525
      PROD=SQRT(NU+DMU+1.D0)*PROD
      IF(NU.GT.DMU) PROD=PROD*SQRT(NU-DMU)
      CALL DXADJ(PROD,IPROD,IERROR)
      IF (IERROR.NE.0) RETURN
      MU=MU+1
      DMU=DMU+1.D0
      GO TO 540
  525 PROD=0.D0
      IPROD=0
      MU=MU+1
      DMU=DMU+1.D0
      GO TO 540
  530 PROD=SQRT(NU+DMU+1.D0)*PROD
      IF(NU.NE.DMU-1.D0) PROD=PROD/SQRT(NU-DMU+1.D0)
      CALL DXADJ(PROD,IPROD,IERROR)
      IF (IERROR.NE.0) RETURN
      NU=NU+1.D0
  540 CONTINUE
      RETURN
      END
      SUBROUTINE DXPQNU (NU1, NU2, MU, THETA, ID, PQA, IPQA, IERROR)
C***BEGIN PROLOGUE  DXPQNU
C***SUBSIDIARY
C***PURPOSE  To compute the values of Legendre functions for DXLEGF.
C            This subroutine calculates initial values of P or Q using
C            power series, then performs forward nu-wise recurrence to
C            obtain P(-MU,NU,X), Q(0,NU,X), or Q(1,NU,X). The nu-wise
C            recurrence is stable for P for all mu and for Q for mu=0,1.
C***LIBRARY   SLATEC
C***CATEGORY  C3A2, C9
C***TYPE      DOUBLE PRECISION (XPQNU-S, DXPQNU-D)
C***KEYWORDS  LEGENDRE FUNCTIONS
C***AUTHOR  Smith, John M., (NBS and George Mason University)
C***ROUTINES CALLED  DXADD, DXADJ, DXPSI
C***COMMON BLOCKS    DXBLK1
C***REVISION HISTORY  (YYMMDD)
C   820728  DATE WRITTEN
C   890126  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Changed all specific intrinsics to generic.  (WRB)
C           Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  DXPQNU
      DOUBLE PRECISION A,NU,NU1,NU2,PQ,PQA,DXPSI,R,THETA,W,X,X1,X2,XS,
     1 Y,Z
      DOUBLE PRECISION DI,DMU,PQ1,PQ2,FACTMU,FLOK
      DIMENSION PQA(*),IPQA(*)
      COMMON /DXBLK1/ NBITSF
      SAVE /DXBLK1/
C
C        J0, IPSIK, AND IPSIX ARE INITIALIZED IN THIS SUBROUTINE.
C        J0 IS THE NUMBER OF TERMS USED IN SERIES EXPANSION
C        IN SUBROUTINE DXPQNU.
C        IPSIK, IPSIX ARE VALUES OF K AND X RESPECTIVELY
C        USED IN THE CALCULATION OF THE DXPSI FUNCTION.
C
C***FIRST EXECUTABLE STATEMENT  DXPQNU
      IERROR=0
      J0=NBITSF
      IPSIK=1+(NBITSF/10)
      IPSIX=5*IPSIK
      IPQ=0
C        FIND NU IN INTERVAL [-.5,.5) IF ID=2  ( CALCULATION OF Q )
      NU=MOD(NU1,1.D0)
      IF(NU.GE..5D0) NU=NU-1.D0
C        FIND NU IN INTERVAL (-1.5,-.5] IF ID=1,3, OR 4  ( CALC. OF P )
      IF(ID.NE.2.AND.NU.GT.-.5D0) NU=NU-1.D0
C        CALCULATE MU FACTORIAL
      K=MU
      DMU=MU
      IF(MU.LE.0) GO TO 60
      FACTMU=1.D0
      IF=0
      DO 50 I=1,K
      FACTMU=FACTMU*I
   50 CALL DXADJ(FACTMU,IF,IERROR)
      IF (IERROR.NE.0) RETURN
   60 IF(K.EQ.0) FACTMU=1.D0
      IF(K.EQ.0) IF=0
C
C        X=COS(THETA)
C        Y=SIN(THETA/2)**2=(1-X)/2=.5-.5*X
C        R=TAN(THETA/2)=SQRT((1-X)/(1+X)
C
      X=COS(THETA)
      Y=SIN(THETA/2.D0)**2
      R=TAN(THETA/2.D0)
C
C        USE ASCENDING SERIES TO CALCULATE TWO VALUES OF P OR Q
C        FOR USE AS STARTING VALUES IN RECURRENCE RELATION.
C
      PQ2=0.0D0
      DO 100 J=1,2
      IPQ1=0
      IF(ID.EQ.2) GO TO 80
C
C        SERIES FOR P ( ID = 1, 3, OR 4 )
C        P(-MU,NU,X)=1./FACTORIAL(MU)*SQRT(((1.-X)/(1.+X))**MU)
C                *SUM(FROM 0 TO J0-1)A(J)*(.5-.5*X)**J
C
      IPQ=0
      PQ=1.D0
      A=1.D0
      IA=0
      DO 65 I=2,J0
      DI=I
      A=A*Y*(DI-2.D0-NU)*(DI-1.D0+NU)/((DI-1.D0+DMU)*(DI-1.D0))
      CALL DXADJ(A,IA,IERROR)
      IF (IERROR.NE.0) RETURN
      IF(A.EQ.0.D0) GO TO 66
      CALL DXADD(PQ,IPQ,A,IA,PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
   65 CONTINUE
   66 CONTINUE
      IF(MU.LE.0) GO TO 90
      X2=R
      X1=PQ
      K=MU
      DO 77 I=1,K
      X1=X1*X2
   77 CALL DXADJ(X1,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
      PQ=X1/FACTMU
      IPQ=IPQ-IF
      CALL DXADJ(PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
      GO TO 90
C
C        Z=-LN(R)=.5*LN((1+X)/(1-X))
C
   80 Z=-LOG(R)
      W=DXPSI(NU+1.D0,IPSIK,IPSIX)
      XS=1.D0/SIN(THETA)
C
C        SERIES SUMMATION FOR Q ( ID = 2 )
C        Q(0,NU,X)=SUM(FROM 0 TO J0-1)((.5*LN((1+X)/(1-X))
C    +DXPSI(J+1,IPSIK,IPSIX)-DXPSI(NU+1,IPSIK,IPSIX)))*A(J)*(.5-.5*X)**J
C
C        Q(1,NU,X)=-SQRT(1./(1.-X**2))+SQRT((1-X)/(1+X))
C             *SUM(FROM 0 T0 J0-1)(-NU*(NU+1)/2*LN((1+X)/(1-X))
C                 +(J-NU)*(J+NU+1)/(2*(J+1))+NU*(NU+1)*
C     (DXPSI(NU+1,IPSIK,IPSIX)-DXPSI(J+1,IPSIK,IPSIX))*A(J)*(.5-.5*X)**J
C
C        NOTE, IN THIS LOOP K=J+1
C
      PQ=0.D0
      IPQ=0
      IA=0
      A=1.D0
      DO 85 K=1,J0
      FLOK=K
      IF(K.EQ.1) GO TO 81
      A=A*Y*(FLOK-2.D0-NU)*(FLOK-1.D0+NU)/((FLOK-1.D0+DMU)*(FLOK-1.D0))
      CALL DXADJ(A,IA,IERROR)
      IF (IERROR.NE.0) RETURN
   81 CONTINUE
      IF(MU.GE.1) GO TO 83
      X1=(DXPSI(FLOK,IPSIK,IPSIX)-W+Z)*A
      IX1=IA
      CALL DXADD(PQ,IPQ,X1,IX1,PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
      GO TO 85
   83 X1=(NU*(NU+1.D0)*(Z-W+DXPSI(FLOK,IPSIK,IPSIX))+(NU-FLOK+1.D0)
     1  *(NU+FLOK)/(2.D0*FLOK))*A
      IX1=IA
      CALL DXADD(PQ,IPQ,X1,IX1,PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
   85 CONTINUE
      IF(MU.GE.1) PQ=-R*PQ
      IXS=0
      IF(MU.GE.1) CALL DXADD(PQ,IPQ,-XS,IXS,PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
      IF(J.EQ.2) MU=-MU
      IF(J.EQ.2) DMU=-DMU
   90 IF(J.EQ.1) PQ2=PQ
      IF(J.EQ.1) IPQ2=IPQ
      NU=NU+1.D0
  100 CONTINUE
      K=0
      IF(NU-1.5D0.LT.NU1) GO TO 120
      K=K+1
      PQA(K)=PQ2
      IPQA(K)=IPQ2
      IF(NU.GT.NU2+.5D0) RETURN
  120 PQ1=PQ
      IPQ1=IPQ
      IF(NU.LT.NU1+.5D0) GO TO 130
      K=K+1
      PQA(K)=PQ
      IPQA(K)=IPQ
      IF(NU.GT.NU2+.5D0) RETURN
C
C        FORWARD NU-WISE RECURRENCE FOR F(MU,NU,X) FOR FIXED MU
C        USING
C        (NU+MU+1)*F(MU,NU,X)=(2.*NU+1)*F(MU,NU,X)-(NU-MU)*F(MU,NU-1,X)
C        WHERE F(MU,NU,X) MAY BE P(-MU,NU,X) OR IF MU IS REPLACED
C        BY -MU THEN F(MU,NU,X) MAY BE Q(MU,NU,X).
C        NOTE, IN THIS LOOP, NU=NU+1
C
  130 X1=(2.D0*NU-1.D0)/(NU+DMU)*X*PQ1
      X2=(NU-1.D0-DMU)/(NU+DMU)*PQ2
      CALL DXADD(X1,IPQ1,-X2,IPQ2,PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
      CALL DXADJ(PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
      NU=NU+1.D0
      PQ2=PQ1
      IPQ2=IPQ1
      GO TO 120
C
      END
      DOUBLE PRECISION FUNCTION DXPSI (A, IPSIK, IPSIX)
C***BEGIN PROLOGUE  DXPSI
C***SUBSIDIARY
C***PURPOSE  To compute values of the Psi function for DXLEGF.
C***LIBRARY   SLATEC
C***CATEGORY  C7C
C***TYPE      DOUBLE PRECISION (XPSI-S, DXPSI-D)
C***KEYWORDS  PSI FUNCTION
C***AUTHOR  Smith, John M., (NBS and George Mason University)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   820728  DATE WRITTEN
C   890126  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Changed all specific intrinsics to generic.  (WRB)
C           Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  DXPSI
      DOUBLE PRECISION A,B,C,CNUM,CDENOM
      DIMENSION CNUM(12),CDENOM(12)
      SAVE CNUM, CDENOM
C
C        CNUM(I) AND CDENOM(I) ARE THE ( REDUCED ) NUMERATOR
C        AND 2*I*DENOMINATOR RESPECTIVELY OF THE 2*I TH BERNOULLI
C        NUMBER.
C
      DATA CNUM(1),CNUM(2),CNUM(3),CNUM(4),CNUM(5),CNUM(6),CNUM(7),
     1CNUM(8),CNUM(9),CNUM(10),CNUM(11),CNUM(12)
     2    / 1.D0,     -1.D0,    1.D0,     -1.D0, 1.D0,
     3   -691.D0,  1.D0,     -3617.D0, 43867.D0, -174611.D0, 77683.D0,
     4   -236364091.D0/
      DATA CDENOM(1),CDENOM(2),CDENOM(3),CDENOM(4),CDENOM(5),CDENOM(6),
     1 CDENOM(7),CDENOM(8),CDENOM(9),CDENOM(10),CDENOM(11),CDENOM(12)
     2/12.D0,120.D0,   252.D0,   240.D0,132.D0,
     3  32760.D0, 12.D0,  8160.D0, 14364.D0, 6600.D0, 276.D0, 65520.D0/
C***FIRST EXECUTABLE STATEMENT  DXPSI
      N=MAX(0,IPSIX-INT(A))
      B=N+A
      K1=IPSIK-1
C
C        SERIES EXPANSION FOR A .GT. IPSIX USING IPSIK-1 TERMS.
C
      C=0.D0
      DO 12 I=1,K1
      K=IPSIK-I
   12 C=(C+CNUM(K)/CDENOM(K))/B**2
      DXPSI=LOG(B)-(C+.5D0/B)
      IF(N.EQ.0) GO TO 20
      B=0.D0
C
C        RECURRENCE FOR A .LE. IPSIX.
C
      DO 15 M=1,N
   15 B=B+1.D0/(N-M+A)
      DXPSI=DXPSI-B
   20 RETURN
      END
      SUBROUTINE DXQMU (NU1, NU2, MU1, MU2, THETA, X, SX, ID, PQA, IPQA,
     1   IERROR)
C***BEGIN PROLOGUE  DXQMU
C***SUBSIDIARY
C***PURPOSE  To compute the values of Legendre functions for DXLEGF.
C            Method: forward mu-wise recurrence for Q(MU,NU,X) for fixed
C            nu to obtain Q(MU1,NU,X), Q(MU1+1,NU,X), ..., Q(MU2,NU,X).
C***LIBRARY   SLATEC
C***CATEGORY  C3A2, C9
C***TYPE      DOUBLE PRECISION (XQMU-S, DXQMU-D)
C***KEYWORDS  LEGENDRE FUNCTIONS
C***AUTHOR  Smith, John M., (NBS and George Mason University)
C***ROUTINES CALLED  DXADD, DXADJ, DXPQNU
C***REVISION HISTORY  (YYMMDD)
C   820728  DATE WRITTEN
C   890126  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  DXQMU
      DIMENSION PQA(*),IPQA(*)
      DOUBLE PRECISION DMU,NU,NU1,NU2,PQ,PQA,PQ1,PQ2,SX,X,X1,X2
      DOUBLE PRECISION THETA
C***FIRST EXECUTABLE STATEMENT  DXQMU
      IERROR=0
      MU=0
C
C        CALL DXPQNU TO OBTAIN Q(0.,NU1,X)
C
      CALL DXPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
      PQ2=PQA(1)
      IPQ2=IPQA(1)
      MU=1
C
C        CALL DXPQNU TO OBTAIN Q(1.,NU1,X)
C
      CALL DXPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
      NU=NU1
      K=0
      MU=1
      DMU=1.D0
      PQ1=PQA(1)
      IPQ1=IPQA(1)
      IF(MU1.GT.0) GO TO 310
      K=K+1
      PQA(K)=PQ2
      IPQA(K)=IPQ2
      IF(MU2.LT.1) GO TO 330
  310 IF(MU1.GT.1) GO TO 320
      K=K+1
      PQA(K)=PQ1
      IPQA(K)=IPQ1
      IF(MU2.LE.1) GO TO 330
  320 CONTINUE
C
C        FORWARD RECURRENCE IN MU TO OBTAIN
C                  Q(MU1,NU,X),Q(MU1+1,NU,X),....,Q(MU2,NU,X) USING
C             Q(MU+1,NU,X)=-2.*MU*X*SQRT(1./(1.-X**2))*Q(MU,NU,X)
C                               -(NU+MU)*(NU-MU+1.)*Q(MU-1,NU,X)
C
      X1=-2.D0*DMU*X*SX*PQ1
      X2=(NU+DMU)*(NU-DMU+1.D0)*PQ2
      CALL DXADD(X1,IPQ1,-X2,IPQ2,PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
      CALL DXADJ(PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
      PQ2=PQ1
      IPQ2=IPQ1
      PQ1=PQ
      IPQ1=IPQ
      MU=MU+1
      DMU=DMU+1.D0
      IF(MU.LT.MU1) GO TO 320
      K=K+1
      PQA(K)=PQ
      IPQA(K)=IPQ
      IF(MU2.GT.MU) GO TO 320
  330 RETURN
      END
      SUBROUTINE DXQNU (NU1, NU2, MU1, THETA, X, SX, ID, PQA, IPQA,
     1   IERROR)
C***BEGIN PROLOGUE  DXQNU
C***SUBSIDIARY
C***PURPOSE  To compute the values of Legendre functions for DXLEGF.
C            Method: backward nu-wise recurrence for Q(MU,NU,X) for
C            fixed mu to obtain Q(MU1,NU1,X), Q(MU1,NU1+1,X), ...,
C            Q(MU1,NU2,X).
C***LIBRARY   SLATEC
C***CATEGORY  C3A2, C9
C***TYPE      DOUBLE PRECISION (XQNU-S, DXQNU-D)
C***KEYWORDS  LEGENDRE FUNCTIONS
C***AUTHOR  Smith, John M., (NBS and George Mason University)
C***ROUTINES CALLED  DXADD, DXADJ, DXPQNU
C***REVISION HISTORY  (YYMMDD)
C   820728  DATE WRITTEN
C   890126  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  DXQNU
      DIMENSION PQA(*),IPQA(*)
      DOUBLE PRECISION DMU,NU,NU1,NU2,PQ,PQA,PQ1,PQ2,SX,X,X1,X2
      DOUBLE PRECISION THETA,PQL1,PQL2
C***FIRST EXECUTABLE STATEMENT  DXQNU
      IERROR=0
      K=0
      PQ2=0.0D0
      IPQ2=0
      PQL2=0.0D0
      IPQL2=0
      IF(MU1.EQ.1) GO TO 290
      MU=0
C
C        CALL DXPQNU TO OBTAIN Q(0.,NU2,X) AND Q(0.,NU2-1,X)
C
      CALL DXPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
      IF(MU1.EQ.0) RETURN
      K=(NU2-NU1+1.5D0)
      PQ2=PQA(K)
      IPQ2=IPQA(K)
      PQL2=PQA(K-1)
      IPQL2=IPQA(K-1)
  290 MU=1
C
C        CALL DXPQNU TO OBTAIN Q(1.,NU2,X) AND Q(1.,NU2-1,X)
C
      CALL DXPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
      IF(MU1.EQ.1) RETURN
      NU=NU2
      PQ1=PQA(K)
      IPQ1=IPQA(K)
      PQL1=PQA(K-1)
      IPQL1=IPQA(K-1)
  300 MU=1
      DMU=1.D0
  320 CONTINUE
C
C        FORWARD RECURRENCE IN MU TO OBTAIN Q(MU1,NU2,X) AND
C              Q(MU1,NU2-1,X) USING
C              Q(MU+1,NU,X)=-2.*MU*X*SQRT(1./(1.-X**2))*Q(MU,NU,X)
C                   -(NU+MU)*(NU-MU+1.)*Q(MU-1,NU,X)
C
C              FIRST FOR NU=NU2
C
      X1=-2.D0*DMU*X*SX*PQ1
      X2=(NU+DMU)*(NU-DMU+1.D0)*PQ2
      CALL DXADD(X1,IPQ1,-X2,IPQ2,PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
      CALL DXADJ(PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
      PQ2=PQ1
      IPQ2=IPQ1
      PQ1=PQ
      IPQ1=IPQ
      MU=MU+1
      DMU=DMU+1.D0
      IF(MU.LT.MU1) GO TO 320
      PQA(K)=PQ
      IPQA(K)=IPQ
      IF(K.EQ.1) RETURN
      IF(NU.LT.NU2) GO TO 340
C
C              THEN FOR NU=NU2-1
C
      NU=NU-1.D0
      PQ2=PQL2
      IPQ2=IPQL2
      PQ1=PQL1
      IPQ1=IPQL1
      K=K-1
      GO TO 300
C
C         BACKWARD RECURRENCE IN NU TO OBTAIN
C              Q(MU1,NU1,X),Q(MU1,NU1+1,X),....,Q(MU1,NU2,X)
C              USING
C              (NU-MU+1.)*Q(MU,NU+1,X)=
C                       (2.*NU+1.)*X*Q(MU,NU,X)-(NU+MU)*Q(MU,NU-1,X)
C
  340 PQ1=PQA(K)
      IPQ1=IPQA(K)
      PQ2=PQA(K+1)
      IPQ2=IPQA(K+1)
  350 IF(NU.LE.NU1) RETURN
      K=K-1
      X1=(2.D0*NU+1.D0)*X*PQ1/(NU+DMU)
      X2=-(NU-DMU+1.D0)*PQ2/(NU+DMU)
      CALL DXADD(X1,IPQ1,X2,IPQ2,PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
      CALL DXADJ(PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
      PQ2=PQ1
      IPQ2=IPQ1
      PQ1=PQ
      IPQ1=IPQ
      PQA(K)=PQ
      IPQA(K)=IPQ
      NU=NU-1.D0
      GO TO 350
      END
      SUBROUTINE DXRED (X, IX, IERROR)
C***BEGIN PROLOGUE  DXRED
C***PURPOSE  To provide double-precision floating-point arithmetic
C            with an extended exponent range.
C***LIBRARY   SLATEC
C***CATEGORY  A3D
C***TYPE      DOUBLE PRECISION (XRED-S, DXRED-D)
C***KEYWORDS  EXTENDED-RANGE DOUBLE-PRECISION ARITHMETIC
C***AUTHOR  Lozier, Daniel W., (National Bureau of Standards)
C           Smith, John M., (NBS and George Mason University)
C***DESCRIPTION
C     DOUBLE PRECISION X
C     INTEGER IX
C
C                  IF
C                  RADIX**(-2L) .LE. (ABS(X),IX) .LE. RADIX**(2L)
C                  THEN DXRED TRANSFORMS (X,IX) SO THAT IX=0.
C                  IF (X,IX) IS OUTSIDE THE ABOVE RANGE,
C                  THEN DXRED TAKES NO ACTION.
C                  THIS SUBROUTINE IS USEFUL IF THE
C                  RESULTS OF EXTENDED-RANGE CALCULATIONS
C                  ARE TO BE USED IN SUBSEQUENT ORDINARY
C                  DOUBLE-PRECISION CALCULATIONS.
C
C***SEE ALSO  DXSET
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***COMMON BLOCKS    DXBLK2
C***REVISION HISTORY  (YYMMDD)
C   820712  DATE WRITTEN
C   881020  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Changed all specific intrinsics to generic.  (WRB)
C           Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  DXRED
      DOUBLE PRECISION X
      INTEGER IX
      DOUBLE PRECISION RADIX, RADIXL, RAD2L, DLG10R, XA
      INTEGER L, L2, KMAX
      COMMON /DXBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX
      SAVE /DXBLK2/
C
C***FIRST EXECUTABLE STATEMENT  DXRED
      IERROR=0
      IF (X.EQ.0.0D0) GO TO 90
      XA = ABS(X)
      IF (IX.EQ.0) GO TO 70
      IXA = ABS(IX)
      IXA1 = IXA/L2
      IXA2 = MOD(IXA,L2)
      IF (IX.GT.0) GO TO 40
   10 CONTINUE
      IF (XA.GT.1.0D0) GO TO 20
      XA = XA*RAD2L
      IXA1 = IXA1 + 1
      GO TO 10
   20 XA = XA/RADIX**IXA2
      IF (IXA1.EQ.0) GO TO 70
      DO 30 I=1,IXA1
        IF (XA.LT.1.0D0) GO TO 100
        XA = XA/RAD2L
   30 CONTINUE
      GO TO 70
C
   40 CONTINUE
      IF (XA.LT.1.0D0) GO TO 50
      XA = XA/RAD2L
      IXA1 = IXA1 + 1
      GO TO 40
   50 XA = XA*RADIX**IXA2
      IF (IXA1.EQ.0) GO TO 70
      DO 60 I=1,IXA1
        IF (XA.GT.1.0D0) GO TO 100
        XA = XA*RAD2L
   60 CONTINUE
   70 IF (XA.GT.RAD2L) GO TO 100
      IF (XA.GT.1.0D0) GO TO 80
      IF (RAD2L*XA.LT.1.0D0) GO TO 100
   80 X = SIGN(XA,X)
   90 IX = 0
  100 RETURN
      END
      SUBROUTINE DXSET (IRAD, NRADPL, DZERO, NBITS, IERROR)
C***BEGIN PROLOGUE  DXSET
C***PURPOSE  To provide double-precision floating-point arithmetic
C            with an extended exponent range.
C***LIBRARY   SLATEC
C***CATEGORY  A3D
C***TYPE      DOUBLE PRECISION (XSET-S, DXSET-D)
C***KEYWORDS  EXTENDED-RANGE DOUBLE-PRECISION ARITHMETIC
C***AUTHOR  Lozier, Daniel W., (National Bureau of Standards)
C           Smith, John M., (NBS and George Mason University)
C***DESCRIPTION
C
C   SUBROUTINE  DXSET  MUST BE CALLED PRIOR TO CALLING ANY OTHER
C EXTENDED-RANGE SUBROUTINE. IT CALCULATES AND STORES SEVERAL
C MACHINE-DEPENDENT CONSTANTS IN COMMON BLOCKS. THE USER MUST
C SUPPLY FOUR CONSTANTS THAT PERTAIN TO HIS PARTICULAR COMPUTER.
C THE CONSTANTS ARE
C
C          IRAD = THE INTERNAL BASE OF DOUBLE-PRECISION
C                 ARITHMETIC IN THE COMPUTER.
C        NRADPL = THE NUMBER OF RADIX PLACES CARRIED IN
C                 THE DOUBLE-PRECISION REPRESENTATION.
C         DZERO = THE SMALLEST OF 1/DMIN, DMAX, DMAXLN WHERE
C                 DMIN = THE SMALLEST POSITIVE DOUBLE-PRECISION
C                 NUMBER OR AN UPPER BOUND TO THIS NUMBER,
C                 DMAX = THE LARGEST DOUBLE-PRECISION NUMBER
C                 OR A LOWER BOUND TO THIS NUMBER,
C                 DMAXLN = THE LARGEST DOUBLE-PRECISION NUMBER
C                 SUCH THAT LOG10(DMAXLN) CAN BE COMPUTED BY THE
C                 FORTRAN SYSTEM (ON MOST SYSTEMS DMAXLN = DMAX).
C         NBITS = THE NUMBER OF BITS (EXCLUSIVE OF SIGN) IN
C                 AN INTEGER COMPUTER WORD.
C
C ALTERNATIVELY, ANY OR ALL OF THE CONSTANTS CAN BE GIVEN
C THE VALUE 0 (0.0D0 FOR DZERO). IF A CONSTANT IS ZERO, DXSET TRIES
C TO ASSIGN AN APPROPRIATE VALUE BY CALLING I1MACH
C (SEE P.A.FOX, A.D.HALL, N.L.SCHRYER, ALGORITHM 528 FRAMEWORK
C FOR A PORTABLE LIBRARY, ACM TRANSACTIONS ON MATH SOFTWARE,
C V.4, NO.2, JUNE 1978, 177-188).
C
C   THIS IS THE SETTING-UP SUBROUTINE FOR A PACKAGE OF SUBROUTINES
C THAT FACILITATE THE USE OF EXTENDED-RANGE ARITHMETIC. EXTENDED-RANGE
C ARITHMETIC ON A PARTICULAR COMPUTER IS DEFINED ON THE SET OF NUMBERS
C OF THE FORM
C
C               (X,IX) = X*RADIX**IX
C
C WHERE X IS A DOUBLE-PRECISION NUMBER CALLED THE PRINCIPAL PART,
C IX IS AN INTEGER CALLED THE AUXILIARY INDEX, AND RADIX IS THE
C INTERNAL BASE OF THE DOUBLE-PRECISION ARITHMETIC.  OBVIOUSLY,
C EACH REAL NUMBER IS REPRESENTABLE WITHOUT ERROR BY MORE THAN ONE
C EXTENDED-RANGE FORM.  CONVERSIONS BETWEEN  DIFFERENT FORMS ARE
C ESSENTIAL IN CARRYING OUT ARITHMETIC OPERATIONS.  WITH THE CHOICE
C OF RADIX WE HAVE MADE, AND THE SUBROUTINES WE HAVE WRITTEN, THESE
C CONVERSIONS ARE PERFORMED WITHOUT ERROR (AT LEAST ON MOST COMPUTERS).
C (SEE SMITH, J.M., OLVER, F.W.J., AND LOZIER, D.W., EXTENDED-RANGE
C ARITHMETIC AND NORMALIZED LEGENDRE POLYNOMIALS, ACM TRANSACTIONS ON
C MATHEMATICAL SOFTWARE, MARCH 1981).
C
C   AN EXTENDED-RANGE NUMBER  (X,IX)  IS SAID TO BE IN ADJUSTED FORM IF
C X AND IX ARE ZERO OR
C
C           RADIX**(-L) .LE. ABS(X) .LT. RADIX**L
C
C IS SATISFIED, WHERE L IS A COMPUTER-DEPENDENT INTEGER DEFINED IN THIS
C SUBROUTINE. TWO EXTENDED-RANGE NUMBERS IN ADJUSTED FORM CAN BE ADDED,
C SUBTRACTED, MULTIPLIED OR DIVIDED (IF THE DIVISOR IS NONZERO) WITHOUT
C CAUSING OVERFLOW OR UNDERFLOW IN THE PRINCIPAL PART OF THE RESULT.
C WITH PROPER USE OF THE EXTENDED-RANGE SUBROUTINES, THE ONLY OVERFLOW
C THAT CAN OCCUR IS INTEGER OVERFLOW IN THE AUXILIARY INDEX. IF THIS
C IS DETECTED, THE SOFTWARE CALLS XERROR (A GENERAL ERROR-HANDLING
C FORTRAN SUBROUTINE PACKAGE).
C
C   MULTIPLICATION AND DIVISION IS PERFORMED BY SETTING
C
C                 (X,IX)*(Y,IY) = (X*Y,IX+IY)
C OR
C                 (X,IX)/(Y,IY) = (X/Y,IX-IY).
C
C PRE-ADJUSTMENT OF THE OPERANDS IS ESSENTIAL TO AVOID
C OVERFLOW OR  UNDERFLOW OF THE PRINCIPAL PART. SUBROUTINE
C DXADJ (SEE BELOW) MAY BE CALLED TO TRANSFORM ANY EXTENDED-
C RANGE NUMBER INTO ADJUSTED FORM.
C
C   ADDITION AND SUBTRACTION REQUIRE THE USE OF SUBROUTINE DXADD
C (SEE BELOW).  THE INPUT OPERANDS NEED NOT BE IN ADJUSTED FORM.
C HOWEVER, THE RESULT OF ADDITION OR SUBTRACTION IS RETURNED
C IN ADJUSTED FORM.  THUS, FOR EXAMPLE, IF (X,IX),(Y,IY),
C (U,IU),  AND (V,IV) ARE IN ADJUSTED FORM, THEN
C
C                 (X,IX)*(Y,IY) + (U,IU)*(V,IV)
C
C CAN BE COMPUTED AND STORED IN ADJUSTED FORM WITH NO EXPLICIT
C CALLS TO DXADJ.
C
C   WHEN AN EXTENDED-RANGE NUMBER IS TO BE PRINTED, IT MUST BE
C CONVERTED TO AN EXTENDED-RANGE FORM WITH DECIMAL RADIX.  SUBROUTINE
C DXCON IS PROVIDED FOR THIS PURPOSE.
C
C   THE SUBROUTINES CONTAINED IN THIS PACKAGE ARE
C
C     SUBROUTINE DXADD
C USAGE
C                  CALL DXADD(X,IX,Y,IY,Z,IZ,IERROR)
C                  IF (IERROR.NE.0) RETURN
C DESCRIPTION
C                  FORMS THE EXTENDED-RANGE SUM  (Z,IZ) =
C                  (X,IX) + (Y,IY).  (Z,IZ) IS ADJUSTED
C                  BEFORE RETURNING. THE INPUT OPERANDS
C                  NEED NOT BE IN ADJUSTED FORM, BUT THEIR
C                  PRINCIPAL PARTS MUST SATISFY
C                  RADIX**(-2L).LE.ABS(X).LE.RADIX**(2L),
C                  RADIX**(-2L).LE.ABS(Y).LE.RADIX**(2L).
C
C     SUBROUTINE DXADJ
C USAGE
C                  CALL DXADJ(X,IX,IERROR)
C                  IF (IERROR.NE.0) RETURN
C DESCRIPTION
C                  TRANSFORMS (X,IX) SO THAT
C                  RADIX**(-L) .LE. ABS(X) .LT. RADIX**L.
C                  ON MOST COMPUTERS THIS TRANSFORMATION DOES
C                  NOT CHANGE THE MANTISSA OF X PROVIDED RADIX IS
C                  THE NUMBER BASE OF DOUBLE-PRECISION ARITHMETIC.
C
C     SUBROUTINE DXC210
C USAGE
C                  CALL DXC210(K,Z,J,IERROR)
C                  IF (IERROR.NE.0) RETURN
C DESCRIPTION
C                  GIVEN K THIS SUBROUTINE COMPUTES J AND Z
C                  SUCH THAT  RADIX**K = Z*10**J, WHERE Z IS IN
C                  THE RANGE 1/10 .LE. Z .LT. 1.
C                  THE VALUE OF Z WILL BE ACCURATE TO FULL
C                  DOUBLE-PRECISION PROVIDED THE NUMBER
C                  OF DECIMAL PLACES IN THE LARGEST
C                  INTEGER PLUS THE NUMBER OF DECIMAL
C                  PLACES CARRIED IN DOUBLE-PRECISION DOES NOT
C                  EXCEED 60. DXC210 IS CALLED BY SUBROUTINE
C                  DXCON WHEN NECESSARY. THE USER SHOULD
C                  NEVER NEED TO CALL DXC210 DIRECTLY.
C
C     SUBROUTINE DXCON
C USAGE
C                  CALL DXCON(X,IX,IERROR)
C                  IF (IERROR.NE.0) RETURN
C DESCRIPTION
C                  CONVERTS (X,IX) = X*RADIX**IX
C                  TO DECIMAL FORM IN PREPARATION FOR
C                  PRINTING, SO THAT (X,IX) = X*10**IX
C                  WHERE 1/10 .LE. ABS(X) .LT. 1
C                  IS RETURNED, EXCEPT THAT IF
C                  (ABS(X),IX) IS BETWEEN RADIX**(-2L)
C                  AND RADIX**(2L) THEN THE REDUCED
C                  FORM WITH IX = 0 IS RETURNED.
C
C     SUBROUTINE DXRED
C USAGE
C                  CALL DXRED(X,IX,IERROR)
C                  IF (IERROR.NE.0) RETURN
C DESCRIPTION
C                  IF
C                  RADIX**(-2L) .LE. (ABS(X),IX) .LE. RADIX**(2L)
C                  THEN DXRED TRANSFORMS (X,IX) SO THAT IX=0.
C                  IF (X,IX) IS OUTSIDE THE ABOVE RANGE,
C                  THEN DXRED TAKES NO ACTION.
C                  THIS SUBROUTINE IS USEFUL IF THE
C                  RESULTS OF EXTENDED-RANGE CALCULATIONS
C                  ARE TO BE USED IN SUBSEQUENT ORDINARY
C                  DOUBLE-PRECISION CALCULATIONS.
C
C***REFERENCES  Smith, Olver and Lozier, Extended-Range Arithmetic and
C                 Normalized Legendre Polynomials, ACM Trans on Math
C                 Softw, v 7, n 1, March 1981, pp 93--105.
C***ROUTINES CALLED  I1MACH, XERMSG
C***COMMON BLOCKS    DXBLK1, DXBLK2, DXBLK3
C***REVISION HISTORY  (YYMMDD)
C   820712  DATE WRITTEN
C   881020  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Changed all specific intrinsics to generic.  (WRB)
C           Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C           CALLs to XERROR changed to CALLs to XERMSG.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  DXSET
      INTEGER IRAD, NRADPL, NBITS
      DOUBLE PRECISION DZERO, DZEROX
      COMMON /DXBLK1/ NBITSF
      SAVE /DXBLK1/
      DOUBLE PRECISION RADIX, RADIXL, RAD2L, DLG10R
      INTEGER L, L2, KMAX
      COMMON /DXBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX
      SAVE /DXBLK2/
      INTEGER NLG102, MLG102, LG102
      COMMON /DXBLK3/ NLG102, MLG102, LG102(21)
      SAVE /DXBLK3/
      INTEGER IFLAG
      SAVE IFLAG
C
      DIMENSION LOG102(20), LGTEMP(20)
      SAVE LOG102
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
C   LOG102 CONTAINS THE FIRST 60 DIGITS OF LOG10(2) FOR USE IN
C CONVERSION OF EXTENDED-RANGE NUMBERS TO BASE 10 .
      DATA LOG102 /301,029,995,663,981,195,213,738,894,724,493,026,768,
     * 189,881,462,108,541,310,428/
C
C FOLLOWING CODING PREVENTS DXSET FROM BEING EXECUTED MORE THAN ONCE.
C THIS IS IMPORTANT BECAUSE SOME SUBROUTINES (SUCH AS DXNRMP AND
C DXLEGF) CALL DXSET TO MAKE SURE EXTENDED-RANGE ARITHMETIC HAS
C BEEN INITIALIZED. THE USER MAY WANT TO PRE-EMPT THIS CALL, FOR
C EXAMPLE WHEN I1MACH IS NOT AVAILABLE. SEE CODING BELOW.
      DATA IFLAG /0/
C***FIRST EXECUTABLE STATEMENT  DXSET
      IERROR=0
      IF (IFLAG .NE. 0) RETURN
      IRADX = IRAD
      NRDPLC = NRADPL
      DZEROX = DZERO
      IMINEX = 0
      IMAXEX = 0
      NBITSX = NBITS
C FOLLOWING 5 STATEMENTS SHOULD BE DELETED IF I1MACH IS
C NOT AVAILABLE OR NOT CONFIGURED TO RETURN THE CORRECT
C MACHINE-DEPENDENT VALUES.
      IF (IRADX .EQ. 0) IRADX = I1MACH (10)
      IF (NRDPLC .EQ. 0) NRDPLC = I1MACH (14)
      IF (DZEROX .EQ. 0.0D0) IMINEX = I1MACH (15)
      IF (DZEROX .EQ. 0.0D0) IMAXEX = I1MACH (16)
      IF (NBITSX .EQ. 0) NBITSX = I1MACH (8)
      IF (IRADX.EQ.2) GO TO 10
      IF (IRADX.EQ.4) GO TO 10
      IF (IRADX.EQ.8) GO TO 10
      IF (IRADX.EQ.16) GO TO 10
CCCCC CALL XERMSG ('SLATEC', 'DXSET', 'IMPROPER VALUE OF IRAD', 201, 1)
      WRITE(ICOUT,901)
      CALL DPWRST('XXX','BUG ')
  901 FORMAT('***** ERROR FROM DXSET, IMPROPER VALUE OF IRAD.')
      IERROR=201
      RETURN
   10 CONTINUE
      LOG2R=0
      IF (IRADX.EQ.2) LOG2R = 1
      IF (IRADX.EQ.4) LOG2R = 2
      IF (IRADX.EQ.8) LOG2R = 3
      IF (IRADX.EQ.16) LOG2R = 4
      NBITSF=LOG2R*NRDPLC
      RADIX = IRADX
      DLG10R = LOG10(RADIX)
      IF (DZEROX .NE. 0.0D0) GO TO 14
      LX = MIN ((1-IMINEX)/2, (IMAXEX-1)/2)
      GO TO 16
   14 LX = 0.5D0*LOG10(DZEROX)/DLG10R
C RADIX**(2*L) SHOULD NOT OVERFLOW, BUT REDUCE L BY 1 FOR FURTHER
C PROTECTION.
      LX=LX-1
   16 L2 = 2*LX
      IF (LX.GE.4) GO TO 20
CCCCC CALL XERMSG ('SLATEC', 'DXSET', 'IMPROPER VALUE OF DZERO', 202, 1)
      WRITE(ICOUT,902)
      CALL DPWRST('XXX','BUG ')
  902 FORMAT('***** ERROR FROM DXSET, IMPROPER VALUE OF DZERO.')
      IERROR=202
      RETURN
   20 L = LX
      RADIXL = RADIX**L
      RAD2L = RADIXL**2
C    IT IS NECESSARY TO RESTRICT NBITS (OR NBITSX) TO BE LESS THAN SOME
C UPPER LIMIT BECAUSE OF BINARY-TO-DECIMAL CONVERSION. SUCH CONVERSION
C IS DONE BY DXC210 AND REQUIRES A CONSTANT THAT IS STORED TO SOME FIXED
C PRECISION. THE STORED CONSTANT (LOG102 IN THIS ROUTINE) PROVIDES
C FOR CONVERSIONS ACCURATE TO THE LAST DECIMAL DIGIT WHEN THE INTEGER
C WORD LENGTH DOES NOT EXCEED 63. A LOWER LIMIT OF 15 BITS IS IMPOSED
C BECAUSE THE SOFTWARE IS DESIGNED TO RUN ON COMPUTERS WITH INTEGER WORD
C LENGTH OF AT LEAST 16 BITS.
      IF (15.LE.NBITSX .AND. NBITSX.LE.63) GO TO 30
CCCCC CALL XERMSG ('SLATEC', 'DXSET', 'IMPROPER VALUE OF NBITS', 203, 1)
      WRITE(ICOUT,913)
      CALL DPWRST('XXX','BUG ')
  913 FORMAT('***** ERROR FROM DXSET, IMPROPER VALUE OF NBITS.')
      IERROR=203
      RETURN
   30 CONTINUE
      KMAX = 2**(NBITSX-1) - L2
      NB = (NBITSX-1)/2
      MLG102 = 2**NB
      IF (1.LE.NRDPLC*LOG2R .AND. NRDPLC*LOG2R.LE.120) GO TO 40
CCCCC CALL XERMSG ('SLATEC', 'DXSET', 'IMPROPER VALUE OF NRADPL', 204,
CCCCC+             1)
      WRITE(ICOUT,903)
      CALL DPWRST('XXX','BUG ')
  903 FORMAT('***** ERROR FROM DXSET, IMPROPER VALUE OF NRADPL.')
      IERROR=204
      RETURN
   40 CONTINUE
      NLG102 = NRDPLC*LOG2R/NB + 3
      NP1 = NLG102 + 1
C
C   AFTER COMPLETION OF THE FOLLOWING LOOP, IC CONTAINS
C THE INTEGER PART AND LGTEMP CONTAINS THE FRACTIONAL PART
C OF LOG10(IRADX) IN RADIX 1000.
      IC = 0
      DO 50 II=1,20
        I = 21 - II
        IT = LOG2R*LOG102(I) + IC
        IC = IT/1000
        LGTEMP(I) = MOD(IT,1000)
   50 CONTINUE
C
C   AFTER COMPLETION OF THE FOLLOWING LOOP, LG102 CONTAINS
C LOG10(IRADX) IN RADIX MLG102. THE RADIX POINT IS
C BETWEEN LG102(1) AND LG102(2).
      LG102(1) = IC
      DO 80 I=2,NP1
        LG102X = 0
        DO 70 J=1,NB
          IC = 0
          DO 60 KK=1,20
            K = 21 - KK
            IT = 2*LGTEMP(K) + IC
            IC = IT/1000
            LGTEMP(K) = MOD(IT,1000)
   60     CONTINUE
          LG102X = 2*LG102X + IC
   70   CONTINUE
        LG102(I) = LG102X
   80 CONTINUE
C
C CHECK SPECIAL CONDITIONS REQUIRED BY SUBROUTINES...
      IF (NRDPLC.LT.L) GO TO 90
CCCCC CALL XERMSG ('SLATEC', 'DXSET', 'NRADPL .GE. L', 205, 1)
      WRITE(ICOUT,904)
      CALL DPWRST('XXX','BUG ')
  904 FORMAT('***** ERROR FROM DXSET, IMPROPER VALUE OF NRADPL.')
      IERROR=205
      RETURN
   90 IF (6*L.LE.KMAX) GO TO 100
CCCCC CALL XERMSG ('SLATEC', 'DXSET', '6*L .GT. KMAX', 206, 1)
      WRITE(ICOUT,905)
      CALL DPWRST('XXX','BUG ')
  905 FORMAT('***** ERROR FROM DXSET, IMPROPER VALUE OF L.')
      IERROR=206
      RETURN
  100 CONTINUE
      IFLAG = 1
      RETURN
      END
      SUBROUTINE D3DEDC(X,Y,Z,N,
     1X3DEYE,Y3DEYE,Z3DEYE,
     1D3DCXX,D3DCXY,D3DCXZ,
     1D3DCYX,D3DCYY,D3DCYZ,
     1D3DCZX,D3DCZY,D3DCZZ,
     1TERMXX,TERMXY,TERMXZ,
     1TERMYX,TERMYY,TERMYZ,
     1TERMZX,TERMZY,TERMZZ,
     1IBUGPL,ISUBRO,IERROR)
C
C     PURPOSE--COMPUTE DIRECTION COSINES
C              WHICH WILL BE NEEDED TO ROTATE
C              THE 3-D DATA CLOUD ONTO A 2-D PLANE.
C     NOTE--THE DN.. ARE DIRECTION NUMBERS.
C           THE DC.. ARE DIRECTION COSINES.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--88/10
C     ORIGINAL VERSION--MARCH     1979.
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--SEPTEMBER 1988.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGPL
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='D3DE'
      ISUBN2='DC  '
C
      IERROR='NO'
C
      EPS=0.0000001
C
      IF(IBUGPL.EQ.'OFF'.AND.ISUBRO.NE.'DEDC')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF D3DEDC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGPL,ISUBRO,IERROR
   52 FORMAT('IBUGPL,ISUBRO,IERROR = ',3A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)X3DEYE,Y3DEYE,Z3DEYE
   61 FORMAT('X3DEYE, Y3DEYE, Z3DEYE  = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               *********************************************************
C               **  GENERAL DISCUSSION--                               **
C               **  DETERMINE (IN ORIGINAL COORDINATE SYSTEM VALUES)   **
C               **  WHERE THE DATA POINTS FALL ON THE VISUAL PLANE.    **
C               **  FOR EACH (XD,YD,ZD) DATA POINT,                    **
C               **  DETERMINE WHERE THE VISUAL RAY FROM                **
C               **  THE DATA POINT TO OUR EYE                          **
C               **  STRIKES THE VISUAL (PERSPECTIVE) PLANE.            **
C               **  THE VISUAL PLANE IS THAT PLANE                     **
C               **  WHICH IS NORMAL TO OUR EYE                         **
C               **  AND WHICH CONTAINS THE AVERAGE POINT (XM,YM,ZM).   **
C               **  THE EQUATION OF THE VISUAL PLANE IS                **
C               **  (X3DEYE-XM)(X-XM) + (Y3DEYE-YM)(Y-YM) +
C               **                    + (Z3DEYE-YM)(Z-ZM) = 0          **
C               **  WHERE X, Y, Z ARE THE DUMMY VARIABLES              **
C               **  REPRESENTING ANY POINT (X,Y,Z) ON THAT PLANE.      **
C               **  THIS EQUATION MUST BE SOLVED FOR X, Y, AND Z.      **
C               **  THE EQUATIONS OF THE LINE FROM THE DATA POINT
C               **  (XD,YD,ZD)
C               **  TO OUR EYE (X3DEYE,Y3DEYE,Z3DEYE) ARE
C               **  (X-XD)/(X3DEYE-XD) = (Y-YD)/(Y3DEYE-YD)
C               **                     = (Z-ZD)/(Z3DEYE-ZD)
C               **  WHERE (XD,YD,ZD) REPRESENTS A DATA POINT.           **
C               **  THE VISUAL PLANE EQUATION AND THE LINE EQUATIONS    **
C               **  MUST BE COMBINED TO SOLVE FOR THE VALUES (X,Y,Z)    **
C               **  ON THE VISUAL PLANE AS OUR EYE SEES THEM.           **
C               **********************************************************
C
C               **********************************************************
C               **  THE FINAL PLOT STATEMENT WILL INVOLVE
C               **  ONLY 2 VECTORS.
C               **  AT THE MOMENT, THE POINTS (XP,YP,ZP)
C               **  ON THE VISUAL PLANE ARE DEFINED
C               **  BY 3 COORDINATE VALUES.
C               **  TO REDUCE THE 3 COORDINATE VALUES
C               **  TO 2 COORDINATE VALUES,
C               **  WE MUST ROTATE THE VISUAL PLANE
C               **  SO THAT IT IS PARALLEL TO THE ORIGINAL XZ PLANE.
C               **  TO CARRY OUT SUCH A ROTATION, WE MUST
C               **  DETERMINE THE DIRECTION NUMBERS AND DIRECTION COSINES
C               **  OF THE NEW AXES IN TERMS OF THE OLD COORDINATE SYSTEM.
C               **  THE NEW Y AXIS WILL (BY CONSTRUCTION) BE
C               **  ON THE NORMAL LINE TRAVELING FROM
C               **  THE AVERAGE POINT (XM,YM,ZM) TO OUR EYE POINT
C               **  (X3DEYE,Y3DEYE,Z3DEYE)
C               **  AND WILL THEREFORE HAVE DIRECTIONS NUMBERS
C               **  X3DEYE, Y3DEYE, Z3DEYE
C               **  THE NEW Z AXIS WILL BE PERPENDICULAR TO THE NEW Y AXIS
C               **  AND WILL RESIDE IN THE PLANE CONTAINING THE
C               **  THE FOLLOWING 3 POINTS--
C               **      1) THE AVERAGE POINT (XM,YM,ZM)
C               **      2) THE EYE POINT (X3DEYE,Y3DEYE,Z3DEYE)
C               **      3) SOME POINT (SAY (XM,YM,ZM+1)) OF THE OLD Z AXIS
C               **         DISPLACED OVER SO AS TO EMANATE FROM (XM,YM,ZM).
C               **  THE ABOVE 3 POINTS DEFINE A VERTICAL PLANE.
C               **  THE PURPOSE OF THE VERTICAL PLANE IS TO DEFINE
C               **  WHICH DIRECTION IS 'UP' IN THE FINAL PICTURE.
C               **  THE EQUATION OF THE VERTICAL PLANE IS
C               **  (A-XM)(X-XM) + (B-YM)(Y-YM) + (C-ZM)(Z-ZM) = 0 .
C               **  THIS EQUATION MUST BE SOLVED FOR A, B, AND C.
C               **  WITHOUT LOSS OF GENERALITY, A MAY BE INITIALLY SET TO 1.
C               **  THE SOLUTION TURNS OUT TO BE
C               **      A = 1
C               **      B = -X3DEYE/Y3DEYE
C               **      C = 0
C               **  NOTE, HOWEVER, THAT THESE A, B, AND C VALUES
C               **  FOR THIS VERTICAL PLANE WILL BE IDENTICAL TO THE
C               **  DIRECTION NUMBERS FOR THE NORMAL TO THIS VERTICAL PLANE
C               **  WHICH IS IDENTICALLY THE NEW X AXIS
C               **  AND SO THE ABOVE A, B, AND C VALUES DEFINE THE DIRECTION
C               **  DIRECTION NUMBERS FOR THE NEW X AXIS.
C               **  TO SOLVE FOR THE DIRECTION NUMBERS FOR THE NEW Z AXIS,
C               **  WE SEEK 3 DIRECTION NUMBERS D, E, AND F
C               **  WHICH MUST BE PERPENDICULAR TO BOTH THE
C               **  NEW Y AXIS (WITH DIRECTION NUMBERS X3DEYE, Y3DEYE,
C               **  AND Z3DEYE)
C               **  AND THE NEW X AXIS (WITH DIRECTION NUMBERS A, B, AND C ABOVE
C               **  WITHOUT LOSS OF GENERALITY, D MAY BE INITIALLY SET TO 1.
C               **  NOTE THAT WHENEVER 2 LINES ARE PERPENDICULAR,
C               **  THE INNER PRODUCT OF THE DIRECTION NUMBERS MUST = 0.
C               **  WITHOUT LOSS OF GENERALITY, D MAY BE INITIALLY SET TO 1.
C               **  INCORPORATING THE 2 INNER PRODUCT EQUATIONS,
C               **  WE MAY SOLVE FOR E AND F.
C               **  THE SOLUTIONS TURN OUT TO BE
C               **      D = 1
C               **      E = Y3DEYE/X3DEYE
C               **      F = (-X3DEYE*X3DEYE - Y3DEYE*Y3DEYE) / (X3DEYE*Z3DEYE)
C               **
C               **  IN SUMMARY, THE DIRECTION NUMBERS FOR THE 3 NEW AXES
C               **  MAY BE WRITTEN AS
C               **      NEW X AXIS:  Y3DEYE       -X3DEYE     0
C               **      NEW Y AXIS:  X3DEYE       Y3DEYE      Z3DEYE
C               **      NEW Z AXIS:  -X3DEYE*Z3DEYE   -Y3DEYE*Z3DEYE
C               **                                        X3DEYE*X3DEYE+Y3DEYE
C               **  NOTE THAT BY INSPECTION WE SEE RETROSPECTIVELY
C               **  THAT THE 3 INNER PRODUCTS ALL = 0
C               **  AND SO THE 3 DEFINED AXES ARE ALL PERPENDICULAR
C               **  (AS THEY SHOULD BE).
C               **
C               **  THE CORRESPONDING DIRECTION COSINES
C               **  ARE GOTTEN BY NORMALIZATION TO UNITY;
C               **  LET US SYMBOLICALLY REPRESENT THEM BY--
C               **      D3DCXX   D3DCXY   D3DCXZ
C               **      D3DCYX   D3DCYY   D3DCYZ
C               **      D3DCZX   D3DCZY   D3DCZZ
C               **  THE ABOVE RESULTS WERE ACTUALLY ARRIVED AT
C               **  (AND ARE VALID FOR) BY DISPLACING THE OLD ORIGIN
C               **  FROM (0,0,0) TO (XM,YM,ZM).
C               **  THIS SIMPLIFIES THE EQUATIONS CONSIDERABLY.
C               **
C               **  GIVEN THAT WE NOW HAVE THE DIRECTION COSINES
C               **  OF THE NEW AXES IN TERMS OF THE OLD COORDINATES,
C               **  WE MAKE USE OF
C               **  EISENHART (COORDINATE GEOMETRY, PAGE 160) WHICH STATES
C               **  THAT THE LINEAR TRANSFORMATION THAT IS NEEDED TO CARRY OUT
C               **  THE ROTATION FROM THE VISUAL PLANE TO THE XZ PLANE
C               **  IS GIVEN BY
C               **      XT = XM + D3DCXX(X-XM) + D3DCXY(Y-YM) + D3DCXZ(Z-ZM)
C               **      YT = YM + D3DCYX(X-XM) + D3DCYY(Y-YM) + D3DCYZ(Z-ZM)
C               **      ZT = ZM + D3DCZX(X-XM) + D3DCZY(Y-YM) + D3DCZZ(Z-ZM)
C               **
C               **  NOTE THAT BY INSPECTION OF THE ABOVE TRANSFORMATION
C               **  IT IS SEEN THAT (XM,YM,ZM) IS MAPPED INTO (XM,YM,ZM)
C               **  (AS IT SHOULD BE).
C               **  NOTE ALSO THAT THE EYE POINT AND ANY POINT ALONG THE LINE
C               **  OF SIGHT WOULD HAVE BEEN MAPPED INTO (XM,YM,ZM)
C               **  AS IT SHOULD BE.
C               **  NOTE ALSO THAT ALL POINTS ON THE VISUAL PLANE
C               **  SINCE THEY SATISFY
C               **     (X3DEYE-XM)(X-XM) + (Y3DEYE-YM)(Y-YM) + (Z3DEYE-ZM)(Z-ZM)
C               **     = 0
C               **  GETS MAPPED INTO THE CONSTANT YT VALUE OF YT = YM
C               **  AND SO THE TRANSFORMED PLOT SURFACE IS ONE WHICH
C               **  IS PARALLEL TO THE XZ PLANE BUT IS DISPLACED
C               **  YM UNITS OUT FROM THE XZ PLANE.
C               **  THIS PLOT PLANE WILL CONTAIN THE POINT (XM,YM,ZM).
C               ****************************************************************
C
      ISTEPN='31'
      IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'DEDC')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DNXX=Y3DEYE
      DNXY=-X3DEYE
      DNXZ=0.0
      DNYX=X3DEYE
      DNYY=Y3DEYE
      DNYZ=Z3DEYE
      DNZX=-X3DEYE*Z3DEYE
      DNZY=-Y3DEYE*Z3DEYE
      DNZZ=X3DEYE*X3DEYE+Y3DEYE*Y3DEYE
C
      ARGX=DNXX**2+DNXY**2+DNXZ**2
      ARGY=DNYX**2+DNYY**2+DNYZ**2
      ARGZ=DNZX**2+DNZY**2+DNZZ**2
      DENOMX=0.0
      DENOMY=0.0
      DENOMZ=0.0
      IF(ARGX.GT.0.0)DENOMX=SQRT(ARGX)
      IF(ARGY.GT.0.0)DENOMY=SQRT(ARGY)
      IF(ARGZ.GT.0.0)DENOMZ=SQRT(ARGZ)
C
C     ***** 15 LINES OF CODE TO CHECK FOR DIVISION BY 0 ADDED AUGUST 1983 *****
C
      D3DCXX=CPUMAX
      D3DCXY=CPUMAX
      D3DCXZ=CPUMAX
      IF(DENOMX.EQ.0.0)GOTO1119
      D3DCXX=DNXX/DENOMX
      D3DCXY=DNXY/DENOMX
      D3DCXZ=DNXZ/DENOMX
 1119 CONTINUE
C
      D3DCYX=CPUMAX
      D3DCYY=CPUMAX
      D3DCYZ=CPUMAX
      IF(DENOMY.EQ.0.0)GOTO1129
      D3DCYX=DNYX/DENOMY
      D3DCYY=DNYY/DENOMY
      D3DCYZ=DNYZ/DENOMY
 1129 CONTINUE
C
      D3DCZX=CPUMAX
      D3DCZY=CPUMAX
      D3DCZZ=CPUMAX
      IF(DENOMZ.EQ.0.0)GOTO1139
      D3DCZX=DNZX/DENOMZ
      D3DCZY=DNZY/DENOMZ
      D3DCZZ=DNZZ/DENOMZ
 1139 CONTINUE
C
C     THE FOLLOWING IS FROM EIDE ET AL (1985),
C     ENGINEERING GRAPHICS FUNDAMENTALS
C     PAGE 386-387, FORMULA 17.42.
C     ALPHA IS THE ANGLE FROM MY XY (= BOTTTOM) PLANE TO THE EYE VECTOR
C     BETA  IS THE ANGLE FROM MY YZ (= LEFT) TO THE EYE VECTOR
C     (NOTE DIFFERENCE HERE TO EIDE'S NOTATION, HIS Z = MY Y, & VV.)
C
      ARGALP=X3DEYE**2+Y3DEYE**2+Z3DEYE**2
      DENALP=0.0
      IF(ARGALP.GT.0.0)DENALP=SQRT(ARGALP)
      SINALP=Z3DEYE/DENALP
      COSALP=SQRT(1.0-SINALP**2)
C
      SINBET=0.0
      COSBET=1.0
      DENBET=0.0
      ARGBET=X3DEYE**2+Y3DEYE**2
      IF(ARGBET.LE.EPS)GOTO1159
      IF(ARGBET.GT.EPS)DENBET=SQRT(ARGBET)
      SINBET=X3DEYE/DENBET
      COSBET=SQRT(1.0-SINBET**2)
 1159 CONTINUE
C
      TERMXX=COSBET
      TERMXY=(-SINBET)
      TERMXZ=0.0
C
      TERMYX=COSALP*SINBET
      TERMYY=COSALP*COSBET
      TERMYZ=SINALP
C
      TERMZX=(-SINALP*SINBET)
      TERMZY=(-SINALP*COSBET)
      TERMZZ=COSALP
C
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGPL.EQ.'OFF'.AND.ISUBRO.NE.'DEDC')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF D3DEDC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGPL,ISUBRO,IERROR
 9012 FORMAT('IBUGPL,ISUBRO,IERROR = ',3A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)X3DEYE,Y3DEYE,Z3DEYE
 9013 FORMAT('X3DEYE,Y3DEYE,Z3DEYE = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)DNXX,DNXY,DNXZ
 9021 FORMAT('DNXX,DNXY,DNXZ = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)DNYX,DNYY,DNYZ
 9022 FORMAT('DNYX,DNYY,DNYZ = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9023)DNYX,DNYY,DNYZ
 9023 FORMAT('DNZX,DNZY,DNZZ = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9024)D3DCXX,D3DCXY,D3DCXZ
 9024 FORMAT('D3DCXX,D3DCXY,D3DCXZ = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9025)D3DCYX,D3DCYY,D3DCYZ
 9025 FORMAT('D3DCYX,D3DCYY,D3DCYZ = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9026)D3DCZX,D3DCZY,D3DCZZ
 9026 FORMAT('D3DCZX,D3DCZY,D3DCZZ = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9034)TERMXX,TERMXY,TERMXZ
 9034 FORMAT('TERMXX,TERMXY,TERMXZ = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9035)TERMYX,TERMYY,TERMYZ
 9035 FORMAT('TERMYX,TERMYY,TERMYZ = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9036)TERMZX,TERMZY,TERMZZ
 9036 FORMAT('TERMZX,TERMZY,TERMZZ = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE D3DELI(X,Y,Z,N,
     1XEYE0,YEYE0,ZEYE0,
     1XORIG,YORIG,ZORIG,
     1X3DMIN,Y3DMIN,Z3DMIN,
     1X3DMAX,Y3DMAX,Z3DMAX,
     1X3DMID,Y3DMID,Z3DMID,
     1X3DRAN,Y3DRAN,Z3DRAN,
     1X3DEYE,Y3DEYE,Z3DEYE,
     1X3DORI,Y3DORI,Z3DORI,
     1XPRIME,YPRIME,ZPRIME,
     1IBUGPL,ISUBRO,IERROR)
C
C     PURPOSE--COMPUTE MIN, MAX, MID, AND RANGE OF THE RAW DATA.
C              COMPUTE EYE COORDINATES.
C              COMPUTE ORIGIN COORDINATES
C              COMPUTE VISUAL EXTREME POINTS ON THE
C                 ORTHOGNORMAL PLANE THROUGH (X3DMID,Y3DMID,Z3DMID)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--88/10
C     ORIGINAL VERSION--MARCH     1979.
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--SEPTEMBER 1988.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGPL
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION Z(*)
C
      DIMENSION XPRIME(*)
      DIMENSION YPRIME(*)
      DIMENSION ZPRIME(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='D3DE'
      ISUBN2='LI  '
C
      IERROR='NO'
C
      EPS=0.0000001
C
      IF(IBUGPL.NE.'ON'.AND.ISUBRO.NE.'DELI')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF D3DELI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGPL,ISUBRO,IERROR
   52 FORMAT('IBUGPL,ISUBRO,IERROR = ',3A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)XEYE0,YEYE0,ZEYE0
   61 FORMAT('XEYE0, YEYE0, ZEYE0  = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)XORIG,YORIG,ZORIG
   62 FORMAT('XORIG, YORIG, ZORIG  = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)N
   71 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO72I=1,N
      WRITE(ICOUT,73)I,X(I),Y(I),Z(I)
   73 FORMAT('I,X(I),Y(I),Z(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
   72 CONTINUE
   90 CONTINUE
C
C               ************************************************
C               **  STEP 11--                                 **
C               **  COMPUTE THE MIN AND MAX OF THE RAW DATA.  **
C               ************************************************
C
      ISTEPN='11'
      IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'DELI')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      X3DMIN=X(1)
      X3DMAX=X(1)
      Y3DMIN=Y(1)
      Y3DMAX=Y(1)
      Z3DMIN=Z(1)
      Z3DMAX=Z(1)
C
      DO1100I=1,N
      IF(X(I).LT.X3DMIN)X3DMIN=X(I)
      IF(X(I).GT.X3DMAX)X3DMAX=X(I)
      IF(Y(I).LT.Y3DMIN)Y3DMIN=Y(I)
      IF(Y(I).GT.Y3DMAX)Y3DMAX=Y(I)
      IF(Z(I).LT.Z3DMIN)Z3DMIN=Z(I)
      IF(Z(I).GT.Z3DMAX)Z3DMAX=Z(I)
 1100 CONTINUE
      X3DRAN=X3DMAX-X3DMIN
      Y3DRAN=Y3DMAX-Y3DMIN
      Z3DRAN=Z3DMAX-Z3DMIN
C
C               *******************************************
C               **  STEP 12--                            **
C               **  COMPUTE MIDRANGES FOR THE X, Y,      **
C               **  AND Z VECTORS.                       **
C               **  THIS WILL DEFINE THE 'MIDDLE POINT'  **
C               **  OF THE 3-D PLOT.                     **
C               *******************************************
C
      ISTEPN='12'
      IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'DELI')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      X3DMID=(X3DMIN+X3DMAX)/2.0
      Y3DMID=(Y3DMIN+Y3DMAX)/2.0
      Z3DMID=(Z3DMIN+Z3DMAX)/2.0
C
C               *******************************************
C               **  STEP 13--                            **
C               **  COMPUTE EYE COORDINATES.             88
C               **  IF (XEYE0,YEYE0,ZEYE0) IS UNDEFINED  **
C               **  (THAT IS,    = CPU MINIMUM),         **
C               **  THEN COMPUTE DEFAULT VALUES.         **
C               *******************************************
C
      ISTEPN='13'
      IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'DELI')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      X3DEYE=XEYE0
      Y3DEYE=YEYE0
      Z3DEYE=ZEYE0
      IF(XEYE0.LE.CPUMIN)X3DEYE=X3DMAX+3.0*X3DRAN
      IF(YEYE0.LE.CPUMIN)Y3DEYE=Y3DMAX+3.0*Y3DRAN
      IF(ZEYE0.LE.CPUMIN)Z3DEYE=Z3DMAX+3.0*Z3DRAN
C
C               ***************************************************
C               **  STEP 14--                                    **
C               **  COMPUTE THE ENDPONTS OF THE 3-PRONGED AXIS.  **
C               ***************************************************
C
      ISTEPN='14'
      IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'DELI')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      FACTOR=1.25
C
      X3DORI=XORIG
      Y3DORI=YORIG
      Z3DORI=ZORIG
      IF(XORIG.EQ.CPUMIN)X3DORI=X3DMIN
      IF(YORIG.EQ.CPUMIN)Y3DORI=Y3DMIN
      IF(ZORIG.EQ.CPUMIN)Z3DORI=Z3DMIN
C
      XPRIME(1)=X3DORI
      YPRIME(1)=Y3DORI
      ZPRIME(1)=Z3DORI
C
      XPRIME(2)=X3DORI+FACTOR*X3DRAN
      YPRIME(2)=Y3DORI
      ZPRIME(2)=Z3DORI
C
      XPRIME(3)=X3DORI
      YPRIME(3)=Y3DORI
      ZPRIME(3)=Z3DORI
C
      XPRIME(4)=X3DORI
      YPRIME(4)=Y3DORI+FACTOR*Y3DRAN
      ZPRIME(4)=Z3DORI
C
      XPRIME(5)=X3DORI
      YPRIME(5)=Y3DORI
      ZPRIME(5)=Z3DORI
C
      XPRIME(6)=X3DORI
      YPRIME(6)=Y3DORI
      ZPRIME(6)=Z3DORI+FACTOR*Z3DRAN
C
C               ***************************************************************
C               **  STEP 15--                                                **
C               **  DETERMINE 3 POINTS WHICH WILL DEFINE EXTREMAL POINTS     **
C               **  ON THE VISUAL PLANE.                                     **
C               **  THIS IS NEEDED SO THAT THE UNDERLYING GRAPHICS SOFTWARE  **
C               **  WILL SHOW A CLOSE POINT/CLOUD/FIGURE                     **
C               **  AS BEING LARGE IN APPEARANCE,                            **
C               **  AND A DISTANT POINT/CLOUD/FIGURE                         **
C               **  AS BEING SMALL IN APPEARANCE.                            **
C               **  SUCH A STEP IS NECESSARY BECAUSE THE                     **
C               **  UNDERLYING GRAPHICS SOFTWARE WILL BY DEFAULT             **
C               **  GIVE FULL RESOLUTION TO ALL DATA CLOUDS/FIGRUES          **
C               **  WHICH WILL HAVE THE NET EFFECT OF                        **
C               **  ALL DATA CLOUDS/FIGURES BEING LARGE.                     **
C               **  THE 3 CALCULATED EXTREMAL POINTS WILL NEVER              **
C               **  EXPLICITELY APPEAR ON THE PLOT (THEY WILL                **
C               **  HAVE A BLANK PLOT CHARAXCTER AUTOMATICALLY);             **
C               **  THERE EXISTENCE ONLY SERVES TO ASSURE THAT THE           **
C               **  PLOT WINDOW IS APPROPRIATELY STRETCHED.                  **
C               ***************************************************************
C
C               ************************************************************
C               **  STEP 15.1--                                           **
C               **  DEFINE THE PERIPHERAL VISION ANGLE.                   **
C               **  THIS HAS BEEN SET TO 60 DEGREES                       **
C               **  (30   DEGREES ABOVE THE NORMAL LINE                   **
C               **  TO THE VISUAL PLANE AND 30   DEGREES BELOW            **
C               **  THE NORMAL LINE TO THE PLANE).                        **
C               **  COMPUTE THE RADIUS OF THE CIRCLE ON THE VISUAL PLANE  **
C               **  WHICH IS JUST AT THE EDGE OF VISIBILITY--             **
C               **  THE LARGER THE PERIPHERAL ANGLE,                      **
C               **  THE LARGER THE RADIUS, AND VICE VERSA.                **
C               ************************************************************
C
      ISTEPN='15.1'
      IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'DELI')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      THETA=3.1415926/12.0
      ARG=(X3DEYE-X3DMID)**2+(Y3DEYE-Y3DMID)**2+(Z3DEYE-Z3DMID)**2
      DIST=0.0
      IF(ARG.GT.0.0)DIST=SQRT(ARG)
      RADIUS=DIST*TAN(THETA)
      IF(IBUGPL.NE.'ON'.AND.ISUBRO.NE.'DELI')GOTO1519
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1511)
 1511 FORMAT('***** FROM THE MIDDLE OF D3DELI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1512)THETA,ARG,DIST,RADIUS
 1512 FORMAT('THETA,ARG,DIST,RADIUS = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
 1519 CONTINUE
C
C               ***********************************************************
C               **  STEP 15.2--                                          **
C               **  DETERMINE THE 2 POINTS ON THIS CIRCLE OF VISIBILITY  **
C               **  WHICH INTERSECT WITH THE X = X3DMID PLANE.             **
C               ***********************************************************
C
      ISTEPN='15.2'
      IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'DELI')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      XD=X3DMID
      YD1=Y3DMID
      YD2=Y3DMID
      ZD1=Z3DMID
      ZD2=Z3DMID
C
C     ***** 7 LINES OF CODE TO ADJUST FOR DIVISION BY 0 ADDED AUGUST 1983 *****
      XDEL=X3DEYE-X3DMID
      IF(XDEL.EQ.0.0)XDEL=EPS
      YDEL=Y3DEYE-Y3DMID
      IF(YDEL.EQ.0.0)YDEL=EPS
      ZDEL=Z3DEYE-Z3DMID
      IF(ZDEL.EQ.0.0)ZDEL=EPS
C
      DISC=1.0+(ZDEL/YDEL)**2
      DENOM=0.0
      IF(DISC.GT.0.0)DENOM=SQRT(DISC)
      IF(DISC.LT.0.0)GOTO1520
      ZD1=Z3DMID+RADIUS/DENOM
      ZD2=Z3DMID+RADIUS/(-DENOM)
      YD1=CPUMIN
      IF(YDEL.NE.0.0)YD1=Y3DMID-ZDEL*(ZD1-Z3DMID)/YDEL
      YD2=CPUMAX
      IF(YDEL.NE.0.0)YD2=Y3DMID-ZDEL*(ZD2-Z3DMID)/YDEL
 1520 CONTINUE
C
      XPRIME(7)=X3DMID
      YPRIME(7)=YD1
      ZPRIME(7)=ZD1
C
      XPRIME(8)=X3DMID
      YPRIME(8)=YD2
      ZPRIME(8)=ZD2
C
      IF(IBUGPL.NE.'ON'.AND.ISUBRO.NE.'DELI')GOTO1529
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1521)X3DMID,RADIUS
 1521 FORMAT('X3DMID,RADIUS = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1522)DISC,DENOM
 1522 FORMAT('DISC,DENOM = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1523)XD,YD1,YD2,ZD1,ZD2
 1523 FORMAT('XD,YD1,YD2,ZD1,ZD2 = ',5E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1524)XPRIME(7),YPRIME(7),ZPRIME(7)
 1524 FORMAT('XPRIME(7),YPRIME(7),ZPRIME(7)    = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1525)XPRIME(8),YPRIME(8),ZPRIME(8)
 1525 FORMAT('XPRIME(8),YPRIME(8),ZPRIME(8)    = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
 1529 CONTINUE
C
C               ***********************************************************
C               **  STEP 15.3--                                          **
C               **  DETERMINE THE 2 POINTS ON THIS CIRCLE OF VISIBILITY  **
C               **  WHICH INTERSECT WITH THE Y = Y3DMID PLANE.             **
C               ***********************************************************
C
      ISTEPN='15.3'
      IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'DELI')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      XD1=X3DMID
      XD2=X3DMID
      YD=Y3DMID
      ZD1=Z3DMID
      ZD2=Z3DMID
C
C     ***** 3 LINES OF CODE TO CHECK FOR DIVISION BY 0 ADDED AUGUST 1983 *****
      DISC=CPUMAX
      IF(XDEL.NE.0.0)DISC=1.0+(ZDEL/XDEL)**2
      DENOM=0.0
      IF(DISC.GT.0.0)DENOM=SQRT(DISC)
      IF(DISC.LT.0.0)GOTO1530
      ZD1=Z3DMID+RADIUS/DENOM
      ZD2=Z3DMID+RADIUS/(-DENOM)
      XD1=CPUMIN
      IF(XDEL.NE.0.0)XD1=X3DMID-ZDEL*(ZD1-Z3DMID)/XDEL
      XD2=CPUMAX
      IF(XDEL.NE.0.0)XD2=X3DMID-ZDEL*(ZD2-Z3DMID)/XDEL
C
 1530 CONTINUE
      XPRIME(9)=XD1
      YPRIME(9)=Y3DMID
      ZPRIME(9)=ZD1
C
      XPRIME(10)=XD2
      YPRIME(10)=Y3DMID
      ZPRIME(10)=ZD2
C
      IF(IBUGPL.NE.'ON'.AND.ISUBRO.NE.'DELI')GOTO1539
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1531)Y3DMID,RADIUS
 1531 FORMAT('Y3DMID,RADIUS = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1532)DISC,DENOM
 1532 FORMAT('DISC,DENOM = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1533)XD1,XD2,YD,ZD1,ZD2
 1533 FORMAT('XD1,XD2,YD,ZD1,ZD2 = ',5E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1534)XPRIME(9),YPRIME(9),ZPRIME(9)
 1534 FORMAT('XPRIME(9),YPRIME(9),ZPRIME(9)    = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1535)XPRIME(10),YPRIME(10),ZPRIME(10)
 1535 FORMAT('XPRIME(10),YPRIME(10),ZPRIME(10) = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
 1539 CONTINUE
C
C               ***********************************************************
C               **  STEP 15.4--                                          **
C               **  DETERMINE THE 2 POINTS ON THIS CIRCLE OF VISIBILITY  **
C               **  WHICH INTERSECT WITH THE Z = Z3DMID PLANE.             **
C               ***********************************************************
C
      ISTEPN='15.4'
      IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'DELI')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      XD1=X3DMID
      XD2=X3DMID
      YD1=Y3DMID
      YD2=Y3DMID
      ZD=Z3DMID
C
C     ***** 3 LINES OF CODE TO CHECK FOR DIVISION BY 0 ADDED AUGUST 1983 *****
      DISC=CPUMAX
      IF(YDEL.NE.0.0)DISC=1.0+(XDEL/YDEL)**2
      DENOM=0.0
      IF(DISC.GT.0.0)DENOM=SQRT(DISC)
      IF(DISC.LT.0.0)GOTO1540
      XD1=X3DMID+RADIUS/DENOM
      XD2=X3DMID+RADIUS/(-DENOM)
      YD1=CPUMIN
      IF(YDEL.NE.0.0)YD1=Y3DMID-XDEL*(XD1-X3DMID)/YDEL
      YD2=CPUMAX
      IF(YDEL.NE.0.0)YD2=Y3DMID-XDEL*(XD2-X3DMID)/YDEL
C
 1540 CONTINUE
      XPRIME(11)=XD1
      YPRIME(11)=YD1
      ZPRIME(11)=Z3DMID
C
      XPRIME(12)=XD2
      YPRIME(12)=YD2
      ZPRIME(12)=Z3DMID
C
      IF(IBUGPL.NE.'ON'.AND.ISUBRO.NE.'DELI')GOTO1549
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1541)Z3DMID,RADIUS
 1541 FORMAT('Z3DMID,RADIUS = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1542)DISC,DENOM
 1542 FORMAT('DISC,DENOM = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1543)XD1,XD2,YD1,YD2,ZD
 1543 FORMAT('XD1,XD2,YD1,YD2,ZD = ',5E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1544)XPRIME(11),YPRIME(11),ZPRIME(11)
 1544 FORMAT('XPRIME(11),YPRIME(11),ZPRIME(11) = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1545)XPRIME(12),YPRIME(12),ZPRIME(12)
 1545 FORMAT('XPRIME(12),YPRIME(12),ZPRIME(12) = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
 1549 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGPL.NE.'ON'.AND.ISUBRO.NE.'DELI')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF D3DELI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGPL,ISUBRO,IERROR
 9012 FORMAT('IBUGPL,ISUBRO,IERROR = ',3A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)N
 9021 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9022I=1,N
      WRITE(ICOUT,9023)I,X(I),Y(I),Z(I)
 9023 FORMAT('I,X(I),Y(I),Z(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9022 CONTINUE
      WRITE(ICOUT,9031)X3DMIN,Y3DMIN,Z3DMIN
 9031 FORMAT('X3DMIN,Y3DMIN,Z3DMIN       = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)X3DMAX,Y3DMAX,Z3DMAX
 9032 FORMAT('X3DMAX,Y3DMAX,Z3DMAX       = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9033)X3DMID,Y3DMID,Z3DMID
 9033 FORMAT('X3DMID,Y3DMID,Z3DMID       = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9034)X3DRAN,Y3DRAN,Z3DRAN
 9034 FORMAT('X3DRAN,Y3DRAN,Z3DRAN = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9041)XEYE0,YEYE0,ZEYE0
 9041 FORMAT('XEYE0,YEYE0,ZEYE0    = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9042)X3DEYE,Y3DEYE,Z3DEYE
 9042 FORMAT('X3DEYE,Y3DEYE,Z3DEYE       = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9043)XORIG,YORIG,ZORIG
 9043 FORMAT('XORIG,YORIG,ZORIG    = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9044)X3DORI,Y3DORI,Z3DORI
 9044 FORMAT('X3DORI,Y3DORI,Z3DORI = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      DO9051I=1,12
      WRITE(ICOUT,9052)I,XPRIME(I),YPRIME(I),ZPRIME(I)
 9052 FORMAT('I,XPRIME(I),YPRIME(I),ZPRIME(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9051 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE D3DEMD(X,Y,Z,TEMP,N,
     1XDELMN,YDELMN,ZDELMN)
C
C     PURPOSE--COMPUTE MINIMUM DIFFERENCE
C              BETWEEN X VALUES,
C              BETWEEN Y VALUES,
C              BETWEEN Z VALUES.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--88/11
C     ORIGINAL VERSION--OCTOBER   1979.
C     UPDATED         --JULY      1989.  CHAR*4 STATEMETN FOR IWRITE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1989
      CHARACTER*4 IWRITE
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOBE.INC'
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION Z(*)
      DIMENSION TEMP(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='D3DE'
      ISUBN2='MD  '
C
      IF(IBUGG4.NE.'ON'.AND.ISUBG4.NE.'DEMD')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF D3DEMD--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGG4,ISUBG4,IERRG4
   52 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',3A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)N
   71 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO72I=1,N
      WRITE(ICOUT,73)I,X(I),Y(I),Z(I)
   73 FORMAT('I,X(I),Y(I),Z(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
   72 CONTINUE
   90 CONTINUE
C
C               ************************************************
C               **  STEP 11--                                 **
C               **  COMPUTE MINIMUM DIFFERENCES               **
C               ************************************************
C
      ISTEPN='11'
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'DEMD')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IWRITE='OFF'
C
      XDELMN=CPUMAX
      CALL DISTIN(X,N,IWRITE,TEMP,NTEMP,IBUGG4,IERRG4)
      CALL SORT(TEMP,NTEMP,TEMP)
      IF(NTEMP.LE.1)XDELMN=0.0
      IF(NTEMP.LE.1)GOTO1190
      DO1100I=2,NTEMP
      IM1=I-1
      DEL=TEMP(I)-TEMP(IM1)
      IF(DEL.LE.0.0)GOTO1100
      IF(DEL.LT.XDELMN)XDELMN=DEL
 1100 CONTINUE
 1190 CONTINUE
C
      YDELMN=CPUMAX
      CALL DISTIN(Y,N,IWRITE,TEMP,NTEMP,IBUGG4,IERRG4)
      CALL SORT(TEMP,NTEMP,TEMP)
      IF(NTEMP.LE.1)YDELMN=0.0
      IF(NTEMP.LE.1)GOTO1290
      DO1200I=2,NTEMP
      IM1=I-1
      DEL=TEMP(I)-TEMP(IM1)
      IF(DEL.LE.0.0)GOTO1200
      IF(DEL.LT.YDELMN)YDELMN=DEL
 1200 CONTINUE
 1290 CONTINUE
C
      ZDELMN=CPUMAX
      CALL DISTIN(Z,N,IWRITE,TEMP,NTEMP,IBUGG4,IERRG4)
      CALL SORT(TEMP,NTEMP,TEMP)
      IF(NTEMP.LE.1)ZDELMN=0.0
      IF(NTEMP.LE.1)GOTO1390
      DO1300I=2,NTEMP
      IM1=I-1
      DEL=TEMP(I)-TEMP(IM1)
      IF(DEL.LE.0.0)GOTO1300
      IF(DEL.LT.ZDELMN)ZDELMN=DEL
 1300 CONTINUE
 1390 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.NE.'ON'.AND.ISUBG4.NE.'DEMD')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF D3DEMD--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGG4,ISUBG4,IERRG4
 9012 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',3A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)N,NTEMP
 9021 FORMAT('N,NTEMP = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9022I=1,N
      WRITE(ICOUT,9023)I,X(I),Y(I),Z(I),TEMP(I)
 9023 FORMAT('I,X(I),Y(I),Z(I),TEMP(I) = ',I8,4E15.7)
      CALL DPWRST('XXX','BUG ')
 9022 CONTINUE
      WRITE(ICOUT,9031)XDELMN,YDELMN,ZDELMN
 9031 FORMAT('XDELMN,YDELMN,ZDELMN = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE D3DRBA(XRAW,YRAW,ZRAW,NP,
     1PX,PY,PZ,PX2,PY2,PZ2,PX3,PY3,
     1ICASPL,ICAS3D,
     1ISORSW,
     1IBA2SW,ABA2WI,ABA2BA,
     1IBA2BL,IBA2BC,PBA2BT,
     1IBA2FS,IBA2FC,
     1IBA2PT,IBA2PL,IBA2PC,IBA2TY,IBA2DI,PBA2PS,PBA2PT,
     1XDELMN,YDELMN,ZDELMN,
     1PXMIN,PXMAX,PYMIN,PYMAX,
     1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1IX1TSC,IY1TSC)
C
C     PURPOSE--FOR A GENERAL GRAPHICS DEVICE,
C              AND FOR EACH VALUE IN X(.), DRAW A BAR
C              (= VERTICAL OR HORIZONTAL BAR)
C              FROM THE BASE POINT ABA2BA
C              TO THE POINT Y(.).
C              DO SO FOR A SPECIFIED BAR LINE TYPE,
C              LINES COLOR, AND LINE THICKNESS.
C     NOTE--THE VARIABLES PY(.) AND PX(.) ARE DUMMY VARIABLES
C           WHICH ARE USED IN THE INTERMEDIATE CALCULATIONS
C           AND WHOSE DIMENSIONS ARE DEFINED (FOR EASY OF CHANGE)
C           BACK IN THE MAIN ROUTINE.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87.5
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C     UPDATED         --MAY       1987.
C     UPDATED         --MARCH     1988.  TO FIX PROBLEM WHEREBY ONLY FIRST BAR
C                                        HAD PROPER PATTERN (STOLNICKI).
C     UPDATED         --SEPTEMBER 1988.  RENUMBER
C     UPDATED         --APRIL     1992.  ASP2BA  TO  ABA2BA
C     UPDATED         --APRIL     1992.  IPATTT TO IPATT
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ICAS3D
C
      CHARACTER*4 ISORSW
C
      CHARACTER*4 IBA2SW
      CHARACTER*4 IBA2BL
      CHARACTER*4 IBA2BC
      CHARACTER*4 IBA2FS
      CHARACTER*4 IBA2FC
      CHARACTER*4 IBA2PT
      CHARACTER*4 IBA2PL
      CHARACTER*4 IBA2PC
      CHARACTER*4 IBA2TY
      CHARACTER*4 IBA2DI
C
      CHARACTER*4 IX1TSC
      CHARACTER*4 IY1TSC
C
      CHARACTER*4 ITYPE
C
      CHARACTER*4 IFIG
      CHARACTER*4 IPATT
      CHARACTER*4 ICOL
CCCCC CHARACTER*4 ICOLF
CCCCC CHARACTER*4 ICOLP
      CHARACTER*4 IDIR
C
      CHARACTER*4 IHORPA
      CHARACTER*4 IVERPA
      CHARACTER*4 IDUPPA
      CHARACTER*4 IDDOPA
C
CCCCC CHARACTER*4 IFIGSV
C
      DIMENSION XRAW(*)
      DIMENSION YRAW(*)
      DIMENSION ZRAW(*)
      DIMENSION PX(*)
      DIMENSION PY(*)
      DIMENSION PZ(*)
      DIMENSION PX2(*)
      DIMENSION PY2(*)
      DIMENSION PZ2(*)
      DIMENSION PX3(*)
      DIMENSION PY3(*)
C
      DIMENSION XVECT(2)
      DIMENSION YVECT(2)
      DIMENSION ZVECT(2)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCO3D.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      HOLD=1.0
      ABASE=0.0
      PBASE=0.0
      PBASE2=0.0
      PLEFT=0.0
      PRIGHT=0.0
      AWIDTH=0.0
      PWIDTH=0.0
C
      FXMIN=FX1MIN
      FXMAX=FX1MAX
      FYMIN=FY1MIN
      FYMAX=FY1MAX
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRBA')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF D3DRBA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)NP
   52 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)ICASPL,ICAS3D
   53 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)XDELMN,YDELMN,ZDELMN
   54 FORMAT('XDELMN,YDELMN,ZDELMN = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(NP.LE.3)GOTO69
      DO65I=1,3
      WRITE(ICOUT,66)I,XRAW(I),YRAW(I),ZRAW(I)
   66 FORMAT('I,XRAW(I),YRAW(I),ZRAW(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
      NPM2=NP-2
      DO67I=NPM2,NP
      WRITE(ICOUT,68)I,XRAW(I),YRAW(I),ZRAW(I)
   68 FORMAT('I,XRAW(I),YRAW(I),ZRAW(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
   67 CONTINUE
   69 CONTINUE
      WRITE(ICOUT,70)ISORSW
   70 FORMAT('ISORSW = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)IBA2SW,ABA2WI,ABA2BA
   71 FORMAT('IBA2SW,ABA2WI,ABA2BA = ',A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,72)IBA2BL,IBA2BC,PBA2BT
   72 FORMAT('IBA2BL,IBA2BC,PBA2BT = ',A4,2X,A4,2X,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,73)IBA2FS,IBA2FC
   73 FORMAT('IBA2FS,IBA2FC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,74)IBA2PT,IBA2PL,IBA2PC,IBA2TY,IBA2DI,PBA2PS,PBA2PT
   74 FORMAT('IBA2PT,IBA2PL,IBA2PC,IBA2TY,IBA2DI,PBA2PS,PBA2PT = ',
     1A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,81)X3DEYE,Y3DEYE,Z3DEYE
   81 FORMAT('X3DEYE,Y3DEYE,Z3DEYE = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,84)PXMIN,PXMAX,PYMIN,PYMAX
   84 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,85)FX1MIN,FX1MAX,FY1MIN,FY1MAX
   85 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,86)IX1TSC,IY1TSC
   86 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,89)IBUGG4,ISUBG4,IERRG4
   89 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               *************************************************
C               **  STEP 11--                                  **
C               **  IF CALLED FOR, SORT THE DATA               **
C               **  ACCORDING TO THE HORIZONTAL AXIS VARIABLE  **
C               *************************************************
C
      IDIR=IBA2DI
C
      IF(ISORSW.EQ.'OFF')GOTO1150
      IF(ICASPL.EQ.'PIEC')GOTO1150
      IF(ICAS3D.EQ.'ON')GOTO1150
      IF(ICASPL.EQ.'CONT')GOTO1150
C
      CALL SORTC2(X,Y,NP,PX,PY)
      GOTO1190
C
 1150 CONTINUE
      DO1160I=1,NP
      PX(I)=XRAW(I)
      PY(I)=YRAW(I)
      PZ(I)=ZRAW(I)
 1160 CONTINUE
      GOTO1190
C
 1190 CONTINUE
C
C               ************************************************
C               **  STEP 12--                                 **
C               **  IF A LOG SCALE PLOT IS CALLED FOR,        **
C               **  CHECK THAT ALL DATA POINTS ARE POSITIVE.  **
C               ************************************************
C
      IF(IX1TSC.EQ.'LOG')GOTO1210
      GOTO1290
C
 1210 CONTINUE
      IF(IDIR.EQ.'H')GOTO1215
      GOTO1219
 1215 CONTINUE
CCCCC THE FOLLOWING 2 LINES WERE FIXED    APRIL 1992 (ALAN)
CCCCC IF(ASP2BA.LE.0.0)HOLD=ASP2BA
CCCCC IF(ASP2BA.LE.0.0)GOTO1250
      IF(ABA2BA.LE.0.0)HOLD=ABA2BA
      IF(ABA2BA.LE.0.0)GOTO1250
 1219 CONTINUE
C
      IF(ISORSW.EQ.'ON')GOTO1220
      GOTO1230
C
 1220 CONTINUE
      J=1
      IF(PX(J).LE.0.0)GOTO1250
      GOTO1290
C
 1230 CONTINUE
      DO1235I=1,NP
      J=I
      IF(PX(J).LE.0.0)GOTO1250
 1235 CONTINUE
      GOTO1290
C
 1250 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1251)
 1251 FORMAT('***** ERROR IN D3DRBA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1252)
 1252 FORMAT('      THE LOG OF A NON-POSITIVE DATA VALUE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1253)
 1253 FORMAT('      WAS ENCOUNTERED IN FORMING A PLOT.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1254)
 1254 FORMAT('      DATA MAY NOT BE ZERO OR NEGATIVE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1255)
 1255 FORMAT('      WHEN A LOG SCALE PLOT IS USED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1256)PX(J)
 1256 FORMAT('      THE VALUE = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1257)
 1257 FORMAT('      THIS VALUE CAME FROM THE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1258)
 1258 FORMAT('      HORIZONTAL AXIS VARIABLE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1259)
 1259 FORMAT('      CORRECTIVE ACTION--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1260)
 1260 FORMAT('      CHANGE DATA OR CHANGE LIMITS.')
      CALL DPWRST('XXX','BUG ')
      IERRG4='YES'
      GOTO9000
C
 1290 CONTINUE
C
      IF(IY1TSC.EQ.'LOG')GOTO1310
      GOTO1390
C
 1310 CONTINUE
      IF(IDIR.EQ.'V')GOTO1315
      GOTO1319
 1315 CONTINUE
CCCCC THE FOLLOWING 2 LINES WERE FIXED    APRIL 1992 (ALAN)
CCCCC IF(ASP2BA.LE.0.0)HOLD=ASP2BA
CCCCC IF(ASP2BA.LE.0.0)GOTO1350
      IF(ABA2BA.LE.0.0)HOLD=ABA2BA
      IF(ABA2BA.LE.0.0)GOTO1350
 1319 CONTINUE
C
      IF(ISORSW.EQ.'ON')GOTO1320
      GOTO1330
C
 1320 CONTINUE
      J=1
      IF(PY(J).LE.0.0)HOLD=PY(J)
      IF(PY(J).LE.0.0)GOTO1350
      GOTO1390
C
 1330 CONTINUE
      DO1335I=1,NP
      J=I
      IF(PY(J).LE.0.0)HOLD=PY(J)
      IF(PY(J).LE.0.0)GOTO1350
 1335 CONTINUE
      GOTO1390
C
 1350 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1351)
 1351 FORMAT('***** ERROR IN D3DRBA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1352)
 1352 FORMAT('      THE LOG OF A NON-POSITIVE DATA VALUE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1353)
 1353 FORMAT('      WAS ENCOUNTERED IN FORMING A PLOT.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1354)
 1354 FORMAT('      DATA MAY NOT BE ZERO OR NEGATIVE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1355)
 1355 FORMAT('      WHEN A LOG SCALE PLOT IS USED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1356)HOLD
 1356 FORMAT('      THE VALUE = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1357)
 1357 FORMAT('      THIS VALUE CAME FROM THE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1358)
 1358 FORMAT('      VERTICAL AXIS VARIABLE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1359)
 1359 FORMAT('      CORRECTIVE ACTION--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1360)
 1360 FORMAT('      CHANGE DATA OR CHANGE LIMITS.')
      CALL DPWRST('XXX','BUG ')
      IERRG4='YES'
      GOTO9000
C
 1390 CONTINUE
C
C               ******************************************
C               **  STEP 40--                           **
C               **  IF A LOG SCALE PLOT IS CALLED FOR,  **
C               **  TRANSFORM THE DATA                  **
C               ******************************************
C
      ABASE=ABA2BA
      AWIDTH=ABA2WI
C
      WIDTHX=AWIDTH
      IF(WIDTHX.EQ.CPUMIN.AND.XDELMN.LE.0.0)WIDTHX=1.0
      IF(WIDTHX.EQ.CPUMIN.AND.XDELMN.GT.0.0)WIDTHX=XDELMN
      WIDTHY=AWIDTH
      IF(WIDTHY.EQ.CPUMIN.AND.YDELMN.LE.0.0)WIDTHY=1.0
      IF(WIDTHY.EQ.CPUMIN.AND.YDELMN.GT.0.0)WIDTHY=YDELMN
      WIDTHZ=AWIDTH
      IF(WIDTHZ.EQ.CPUMIN.AND.ZDELMN.LE.0.0)WIDTHZ=1.0
      IF(WIDTHZ.EQ.CPUMIN.AND.ZDELMN.GT.0.0)WIDTHZ=ZDELMN
C
      IF(IX1TSC.EQ.'LOG')GOTO4010
      GOTO4019
 4010 CONTINUE
      IF(IDIR.EQ.'H')ABASE=ALOG10(ABASE)
      DO4015I=1,NP
      PX(I)=ALOG10(PX(I))
 4015 CONTINUE
 4019 CONTINUE
C
      IF(IY1TSC.EQ.'LOG')GOTO4020
      GOTO4029
 4020 CONTINUE
      IF(IDIR.EQ.'V')ABASE=ALOG10(ABASE)
      DO4025I=1,NP
      PY(I)=ALOG10(PY(I))
 4025 CONTINUE
 4029 CONTINUE
C
C               *******************************
C               **  STEP 60--                **
C               **  PREPARE TO MAKE VARIOUS  **
C               **  LINE SETTINGS            **
C               *******************************
C
      ITYPE='LINE'
C
C               **********************************************
C               **  STEP 61--                               **
C               **  TRANSLATE THE CHARACTER REPRESENTATION  **
C               **  OF THE LINE PATTERN                     **
C               **  INTO A NUMERIC REPRESENTATION           **
C               **  WHICH CAN BE UNDERSTOOD BY THE          **
C               **  GRAPHICS DEVICE.                        **
C               **********************************************
C
      IPATT=IBA2BL
      CALL GRTRPA(ITYPE,IPATT,PXSPA,PYSPA,
     1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2)
C
C               *******************************
C               **  STEP 62--                **
C               **  SET THE LINE PATTERN     **
C               **  ON THE GRAPHICS DEVICE.  **
C               *******************************
C
      CALL GRSEPA(ITYPE,IPATT,PXSPA,PYSPA,
     1JPATT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2)
C
C               **********************************************
C               **  STEP 63--                               **
C               **  TRANSLATE THE  DESIRED                  **
C               **  LINE THICKNESS                          **
C               **  INTO A NUMERIC REPRESENTATION           **
C               **  WHICH CAN BE UNDERSTOOD BY THE          **
C               **  GRAPHICS DEVICE.                        **
C               **********************************************
C
      PTHICK=PBA2BT
      CALL GRTRTH(ITYPE,PTHICK,JTHICK,PTHIC2)
C
C               *******************************
C               **  STEP 64--                **
C               **  SET THE LINE THICKNESS   **
C               **  ON THE GRAPHICS DEVICE.  **
C               *******************************
C
      CALL GRSETH(ITYPE,PTHICK,JTHICK,PTHIC2)
C
C               **********************************************
C               **  STEP 65--                               **
C               **  TRANSLATE THE CHARACTER REPRESENTATION  **
C               **  OF THE LINE COLOR                       **
C               **  INTO A NUMERIC REPRESENTATION           **
C               **  WHICH CAN BE UNDERSTOOD BY THE          **
C               **  GRAPHICS DEVICE.                        **
C               **********************************************
C
      ICOL=IBA2BC
      CALL GRTRCO(ITYPE,ICOL,JCOL)
C
C               *******************************
C               **  STEP 66--                **
C               **  SET THE LINE COLOR       **
C               **  ON THE GRAPHICS DEVICE.  **
C               *******************************
C
      CALL GRSECO(ITYPE,ICOL,JCOL)
C
C               **************************************************
C               **  STEP 71--                                   **
C               **  FOR EACH RAW 3-D DATA POINT--               **
C               **     1) MAKE THE BAR                          **
C               **     2) TRANSLATE IT TO 2 DIMENSIONS          **
C               **     3) TRANSLATE IT TO 0-100 UNITS           **
C               **     4) CLIP THE BAR   IF NEEDED              **
C               **     5) DRAW OUT THE BAR                      **
C               **************************************************
C
      IFIG='GENE'
C
      FXMIN=FX1MIN
      FXMAX=FX1MAX
      IF(IX1TSC.EQ.'LOG')FXMIN=ALOG10(FX1MIN)
      IF(IX1TSC.EQ.'LOG')FXMAX=ALOG10(FX1MAX)
C
      FYMIN=FY1MIN
      FYMAX=FY1MAX
      IF(IY1TSC.EQ.'LOG')FYMIN=ALOG10(FY1MIN)
      IF(IY1TSC.EQ.'LOG')FYMAX=ALOG10(FY1MAX)
C
      FXRANG=FXMAX-FXMIN
      FYRANG=FYMAX-FYMIN
      PXRANG=PXMAX-PXMIN
      PYRANG=PYMAX-PYMIN
C
C
      BASEX=ABASE
      BASEY=ABASE
      BASEZ=ABASE
C
      DO7100I=1,NP
C
      CALL D3MKBA(PX,PY,PZ,NP,I,
     1IDIR,
     1WIDTHX,WIDTHY,WIDTHZ,
     1BASEX,BASEY,BASEZ,
     1XVECT,YVECT,ZVECT,IXNEAR,IXFAR,IYNEAR,IYFAR,IZNEAR,IZFAR,
     1PX2,PY2,PZ2,NP2)
C
      CALL D3TR32(PX2,PY2,PZ2,NP2,PX3,PY3,NP3)
C
      CALL D3TRXP(PX3,PY3,NP3,IDIR,ABASE,
     1FXMIN,FXMAX,FXRANG,FYMIN,FYMAX,FYRANG,
     1PXMIN,PXMAX,PXRANG,PYMIN,PYMAX,PYRANG,
     1PX3,PY3,NP3,PBASE)
C
      CALL DPSQUE(PX3,PY3,NP3,
     1PXMIN,PXMAX,PYMIN,PYMAX)
C
      CALL GRDRPL(PX3,PY3,NP3,
CCCCC THE FOLLOWING LINE WAS FIXED   APRIL 1992
CCCCC1IFIG,IPATTT,PTHICK,ICOL,
     1IFIG,IPATT,PTHICK,ICOL,
     1JPATTT,JTHICK,PTHIC2,JCOL)
C
 7100 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRBA')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF D3DRBA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)NP
 9012 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)ICASPL,ICAS3D
 9013 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)ABASE,HOLD,PBASE,PBASE2,PLEFT,PRIGHT
 9014 FORMAT('ABASE,HOLD,PBASE,PBASE2,PLEFT,PRIGHT = ',6E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XDELMN,YDELMN,ZDELMN,AWIDTH,PWIDTH
 9015 FORMAT('XDELMN,YDELMN,ZDELMN,AWIDTH,PWIDTH = ',5E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(NP.LE.3)GOTO9029
      DO9025I=1,3
      WRITE(ICOUT,9026)I,XRAW(I),YRAW(I),ZRAW(I)
 9026 FORMAT('I,XRAW(I),YRAW(I),ZRAW(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9025 CONTINUE
      NPM2=NP-2
      DO9027I=NPM2,NP
      WRITE(ICOUT,9028)I,XRAW(I),YRAW(I),ZRAW(I)
 9028 FORMAT('I,XRAW(I),YRAW(I),ZRAW(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9027 CONTINUE
 9029 CONTINUE
      WRITE(ICOUT,9030)ISORSW
 9030 FORMAT('ISORSW = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)IBA2SW,ABA2WI,ABA2BA
 9031 FORMAT('IBA2SW,ABA2WI,ABA2BA = ',A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)IBA2BL,IBA2BC,PBA2BT
 9032 FORMAT('IBA2BL,IBA2BC,PBA2BT = ',A4,2X,A4,2X,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9033)IBA2FS,IBA2FC
 9033 FORMAT('IBA2FS,IBA2FC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9034)IBA2PT,IBA2PL,IBA2PC,IBA2TY,IBA2DI,PBA2PS,PBA2PT
 9034 FORMAT('IBA2PT,IBA2PL,IBA2PC,IBA2TY,IBA2DI,PBA2PS,PBA2PT = ',
     1A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9041)X3DEYE,Y3DEYE,Z3DEYE
 9041 FORMAT('X3DEYE,Y3DEYE,Z3DEYE    = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9042)WIDTHX,WIDTHY,WIDTHZ
 9042 FORMAT('WIDTHX,WIDTHY,WIDTHZ = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9043)BASEX,BASEY,BASEZ
 9043 FORMAT('BASEX,BASEY,BASEZ    = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9044)PXMIN,PXMAX,PYMIN,PYMAX
 9044 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9045)FX1MIN,FX1MAX,FY1MIN,FY1MAX
 9045 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9046)FXMIN,FXMAX,FYMIN,FYMAX
 9046 FORMAT('FXMIN,FXMAX,FYMIN,FYMAX= ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9047)IX1TSC,IY1TSC
 9047 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9051)IFIG
 9051 FORMAT('IFIG = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9052)IPATT,JPATT
 9052 FORMAT('IPATT,JPATT = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9053)PTHICK,JTHICK,PTHIC2
 9053 FORMAT('PTHICK,JTHICK,PTHIC2 = ',E15.7,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9054)ICOL,JCOL,IDIR
 9054 FORMAT('ICOL,JCOL,IDIR = ',A4,I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9055)ITYPE
 9055 FORMAT('ITYPE = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9069)IBUGG4,ISUBG4,IERRG4
 9069 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE D3DRCH(XRAW,YRAW,ZRAW,PX,PY,PZ,NP,PY2,PX2,NP2,
     1X3D2,
     1ICASPL,ICAS3D,
     1ISORSW,
     1ICH2PA,ICH2FO,ICH2CA,ICH2JU,ICH2DI,ACH2AN,ICH2FI,ICH2CO,
     1PCH2HE,PCH2WI,PCH2TH,PCH2HO,PCH2VO,
     1ITEXSP,
     1PXMIN,PXMAX,PYMIN,PYMAX,
     1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1IX1TSC,IY1TSC,
     1IMPSW2,AMPSCH,AMPSCW)
C
C     PURPOSE--FOR A GENERAL GRAPHICS DEVICE,
C              DRAW A CHARACTER TRACE OF Y(.) VERSUS X(.),
C              THAT IS, DRAW A SPECIFIED MARKER (= CHARACTER) TYPE
C              AT EACH OF THE PLOT POINTS.
C     NOTE--THE VARIABLES PY(.) AND PX(.) ARE DUMMY VARIABLES
C           WHICH ARE USED IN THE INTERMEDIATE CALCULATIONS
C           AND WHOSE DIMENSIONS ARE DEFINED (FOR EASY OF CHANGE)
C           BACK IN THE MAIN ROUTINE.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C     UPDATED         --DECEMBER  1987.  INDEPENDENT CONTROL OF CHAR WIDTH.
C     UPDATED         --SEPTEMBER 1988.  LOG/WEIBULL CHECK AS A SUBROUTINE
C     UPDATED         --SEPTEMBER 1988.  RENUMBER
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ICAS3D
C
      CHARACTER*4 ISORSW
C
      CHARACTER*4 ICH2PA
      CHARACTER*4 ICH2FO
      CHARACTER*4 ICH2CA
      CHARACTER*4 ICH2JU
      CHARACTER*4 ICH2DI
      CHARACTER*4 ICH2FI
      CHARACTER*4 ICH2CO
C
      CHARACTER*4 ITEXSP
C
      CHARACTER*4 IX1TSC
      CHARACTER*4 IY1TSC
C
      CHARACTER*4 IFIG
      CHARACTER*4 IPATT
      CHARACTER*4 IFONT
      CHARACTER*4 ICASE
      CHARACTER*4 IJUST
      CHARACTER*4 IDIR
      CHARACTER*4 IFILL
      CHARACTER*4 ICOL
C
      CHARACTER*4 ISYMBL
      CHARACTER*4 ISPAC
      CHARACTER*4 IMPSW2
C
      CHARACTER*4 ICASAX
C
      DIMENSION XRAW(*)
      DIMENSION YRAW(*)
      DIMENSION ZRAW(*)
      DIMENSION PX(*)
      DIMENSION PY(*)
      DIMENSION PZ(*)
      DIMENSION PY2(*)
      DIMENSION PX2(*)
      DIMENSION X3D2(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCO3D.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      FXMIN=FX1MIN
      FXMAX=FX1MAX
      FYMIN=FY1MIN
      FYMAX=FY1MAX
C
      AHUNDR=100.0
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRCH')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF D3DRCH--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)NP
   52 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)ICASPL,ICAS3D
   53 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      IF(NP.LE.3)GOTO69
      DO65I=1,3
      WRITE(ICOUT,66)I,XRAW(I),YRAW(I),ZRAW(I)
   66 FORMAT('I,XRAW(I),YRAW(I),ZRAW(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
      NPM2=NP-2
      DO67I=NPM2,NP
      WRITE(ICOUT,68)I,XRAW(I),YRAW(I),ZRAW(I)
   68 FORMAT('I,XRAW(I),YRAW(I),ZRAW(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
   67 CONTINUE
   69 CONTINUE
      WRITE(ICOUT,70)ISORSW
   70 FORMAT('ISORSW = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,74)ICH2PA
   74 FORMAT('ICH2PA= ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,75)ICH2FO
   75 FORMAT('ICH2FO= ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,76)ICH2JU
   76 FORMAT('ICH2JU= ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,77)ICH2DI
   77 FORMAT('ICH2DI= ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,78)ACH2AN
   78 FORMAT('ACH2AN= ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,79)ICH2FI
   79 FORMAT('ICH2FI= ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,80)ICH2CO
   80 FORMAT('ICH2CO= ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,81)PCH2HE
   81 FORMAT('PCH2HE= ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,82)PCH2WI
   82 FORMAT('PCH2WI= ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,83)PCH2TH,PCH2VO,PCH2HO
   83 FORMAT('PCH2TH,PCH2VO,PCH2HO= ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,84)ITEXSP
   84 FORMAT('ITEXSP = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,85)PXMIN,PXMAX,PYMIN,PYMAX
   85 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,86)FX1MIN,FX1MAX,FY1MIN,FY1MAX
   86 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,87)IX1TSC,IY1TSC
   87 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,89)IBUGG4,ISUBG4,IERRG4
   89 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               *************************************************
C               **  STEP 10--                                  **
C               **  IF CALLED FOR, SORT THE DATA               **
C               **  ACCORDING TO THE HORIZONTAL AXIS VARIABLE  **
C               *************************************************
C
      IF(ISORSW.EQ.'OFF')GOTO1150
      IF(ICASPL.EQ.'PIEC')GOTO1150
      IF(ICAS3D.EQ.'ON')GOTO1150
C
      CALL SORTC2(X,Y,NP,PX,PY)
      GOTO1190
C
 1150 CONTINUE
      DO1160I=1,NP
      PX(I)=XRAW(I)
      PY(I)=YRAW(I)
      PZ(I)=ZRAW(I)
 1160 CONTINUE
      GOTO1190
C
 1190 CONTINUE
C
C               **********************************************************
C               **  STEP 21--                                           **
C               **  IF A NON-LINEAR SCALE PLOT IS CALLED FOR,           **
C               **  CHECK THAT ALL   HORIZ. AXIS DATA POINTS            **
C               **  ARE IN VALID RANGE.                                 **
C               **  IF A LOG SCALE PLOT IS CALLED FOR,                  **
C               **  CHECK THAT ALL   HORIZ.  AXIS DATA POINTS ARE > 0.  **
C               **  IF A WEIBULL SCALE PLOT IS CALLED FOR,              **
C               **  CHECK THAT ALL   HORIZ. AXIS DATA POINTS ARE        **
C               **  STRICTLY > 0 AND STRICTLY < 100                     **
C               **********************************************************
C
      IF(IX1TSC.EQ.'LOG')GOTO2110
      GOTO2119
 2110 CONTINUE
      ICASAX='2DHO'
      CALL CKLOSC(PX,NP,ISORSW,ICASAX,
     1ISUBG4,IBUGG4,IERRG4)
      IF(IERRG4.EQ.'YES')GOTO9000
 2119 CONTINUE
C
      IF(IX1TSC.EQ.'WEIB')GOTO2120
      GOTO2129
 2120 CONTINUE
      ICASAX='2DHO'
      CALL CKPRSC(PX,NP,ISORSW,ICASAX,
     1ISUBG4,IBUGG4,IERRG4)
      IF(IERRG4.EQ.'YES')GOTO9000
 2129 CONTINUE
C
C               **********************************************************
C               **  STEP 22--                                           **
C               **  IF A NON-LINEAR SCALE PLOT IS CALLED FOR,           **
C               **  CHECK THAT ALL   VERT.  AXIS DATA POINTS            **
C               **  ARE IN VALID RANGE.                                 **
C               **  IF A LOG SCALE PLOT IS CALLED FOR,                  **
C               **  CHECK THAT ALL   VERT.   AXIS DATA POINTS ARE > 0.  **
C               **  IF A WEIBULL SCALE PLOT IS CALLED FOR,              **
C               **  CHECK THAT ALL   VERT.  AXIS DATA POINTS ARE        **
C               **  STRICTLY > 0 AND STRICTLY < 100                     **
C               **********************************************************
C
      IF(IY1TSC.EQ.'LOG')GOTO2210
      GOTO2219
 2210 CONTINUE
      ICASAX='2DVE'
      CALL CKLOSC(PY,NP,ISORSW,ICASAX,
     1ISUBG4,IBUGG4,IERRG4)
      IF(IERRG4.EQ.'YES')GOTO9000
 2219 CONTINUE
C
      IF(IY1TSC.EQ.'WEIB')GOTO2220
      GOTO2229
 2220 CONTINUE
      ICASAX='2DVE'
      CALL CKPRSC(PY,NP,ISORSW,ICASAX,
     1ISUBG4,IBUGG4,IERRG4)
      IF(IERRG4.EQ.'YES')GOTO9000
 2229 CONTINUE
C
C               ******************************************
C               **  STEP 41--                           **
C               **  IF A LOG SCALE PLOT IS CALLED FOR,  **
C               **  TRANSFORM THE DATA                  **
C               ******************************************
C
      IF(IX1TSC.EQ.'LOG')GOTO4110
      GOTO4119
 4110 CONTINUE
      DO4115I=1,NP
      PX(I)=ALOG10(PX(I))
 4115 CONTINUE
 4119 CONTINUE
C
      IF(IY1TSC.EQ.'LOG')GOTO4120
      GOTO4129
 4120 CONTINUE
      DO4125I=1,NP
      PY(I)=ALOG10(PY(I))
 4125 CONTINUE
 4129 CONTINUE
C
C               ******************************************
C               **  STEP 42--                           **
C               **  IF A WEIBULL SCALE PLOT IS CALLED FOR,  **
C               **  TRANSFORM THE DATA                  **
C               ******************************************
C
      IF(IX1TSC.EQ.'WEIB')GOTO4210
      GOTO4219
 4210 CONTINUE
      DO4215I=1,NP
      PX(I)=ALOG(ALOG(AHUNDR/(AHUNDR-PX(I))))
 4215 CONTINUE
 4219 CONTINUE
C
      IF(IY1TSC.EQ.'WEIB')GOTO4220
      GOTO4229
 4220 CONTINUE
      DO4225I=1,NP
      PY(I)=ALOG(ALOG(AHUNDR/(AHUNDR-PY(I))))
 4225 CONTINUE
 4229 CONTINUE
C
C               **************************************************
C               **  STEP 51--                                   **
C               **  FORM THE CHARACTERS IN RAW 3-D SPACE.       **
C               **************************************************
C
C               **************************************************
C               **  STEP 52--                                   **
C               **  IF HIDDEN LINE REMOVAL IS ON,               **
C               **  DETERMINE IF ANY PART                       **
C               **  OF THE CHARACTER IS VISIBLE;                **
C               **  FORM SUBCHARACTERS.                         **
C               **************************************************
C
C               **************************************************
C               **  STEP 53--                                   **
C               **  TRANSLATE THE VISIBLE SUB-CHARACTERS        **
C               **  FROM THE RAW 3-D SPACE                      **
C               **  TO THE FINAL VISUAL 2-D PLANE.              **
C               **************************************************
C
      CALL D3TR32(PX,PY,PZ,NP,PX,PY,NP)
C
C               *****************************************************
C               **  STEP 54--                                      **
C               **  TRANSLATE THE 2-D PLANE DATA POINTS            **
C               **  INTO STANDARDIZED (0.0 TO 100.0) COORDINATES.  **
C               *****************************************************
C
      FXMIN=FX1MIN
      FXMAX=FX1MAX
      IF(IX1TSC.EQ.'LOG')FXMIN=ALOG10(FX1MIN)
      IF(IX1TSC.EQ.'LOG')FXMAX=ALOG10(FX1MAX)
      IF(IX1TSC.EQ.'WEIB')FXMIN=ALOG(ALOG(AHUNDR/(AHUNDR-FX1MIN)))
      IF(IX1TSC.EQ.'WEIB')FXMAX=ALOG(ALOG(AHUNDR/(AHUNDR-FX1MAX)))
C
      FYMIN=FY1MIN
      FYMAX=FY1MAX
      IF(IY1TSC.EQ.'LOG')FYMIN=ALOG10(FY1MIN)
      IF(IY1TSC.EQ.'LOG')FYMAX=ALOG10(FY1MAX)
      IF(IY1TSC.EQ.'WEIB')FYMIN=ALOG(ALOG(AHUNDR/(AHUNDR-FY1MIN)))
      IF(IY1TSC.EQ.'WEIB')FYMAX=ALOG(ALOG(AHUNDR/(AHUNDR-FY1MAX)))
C
      FXRANG=FXMAX-FXMIN
      FYRANG=FYMAX-FYMIN
      PXRANG=PXMAX-PXMIN
      PYRANG=PYMAX-PYMIN
C
      DO5410I=1,NP
      FXRATI=(PX(I)-FXMIN)/FXRANG
      FYRATI=(PY(I)-FYMIN)/FYRANG
      PX(I)=PXMIN+FXRATI*PXRANG
      PY(I)=PYMIN+FYRATI*PYRANG
 5410 CONTINUE
C
      DO5420I=1,NP
      PX(I)=PX(I)+PCH2HO
      PY(I)=PY(I)+PCH2VO
 5420 CONTINUE
C
C               ***********************************************
C               **  STEP 60--                                **
C               **  WRITE OUT THE MARKERS (PLOT CHARACTERS)  **
C               **  AT THE PLOT POINTS                       **
C               ***********************************************
C
      IFIG='GENE'
      IPATT=ICH2PA
      IFONT=ICH2FO
      ICASE=ICH2CA
      IJUST=ICH2JU
      IDIR=ICH2DI
      ANGLE=ACH2AN
      IFILL=ICH2FI
      ICOL=ICH2CO
      PHEIGH=PCH2HE
CCCCC PWIDTH=0.5*PHEIGH
CCCCC PWIDTH=PHEIGH*(ANUMVP/ANUMHP)      DECEMBER 1987  TEST
      PWIDTH=PCH2WI
      PVEGAP=PHEIGH/2.0
      PHOGAP=PWIDTH/2.0
      PTHICK=PCH2TH
      ISYMBL=ICH2PA
      ISPAC=ITEXSP
C
      CALL DPCLCH(PX,PY,NP,PX2,PY2,NP2,X3D2,
     1PXMIN,PXMAX,PYMIN,PYMAX,
     1ISORSW,
     1IFIG,IPATT,IFONT,ICASE,IJUST,IDIR,ANGLE,IFILL,ICOL,
     1PHEIGH,PWIDTH,PVEGAP,PHOGAP,PTHICK,
     1IMPSW2,AMPSCH,AMPSCW,
     1ISYMBL,ISPAC)
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRCH')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF D3DRCH--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)NP
 9012 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)ICASPL,ICAS3D
 9013 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      IF(NP.LE.3)GOTO9029
      DO9025I=1,3
      WRITE(ICOUT,9026)I,XRAW(I),YRAW(I),ZRAW(I)
 9026 FORMAT('I,XRAW(I),YRAW(I),ZRAW(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9025 CONTINUE
      NPM2=NP-2
      DO9027I=NPM2,NP
      WRITE(ICOUT,9028)I,XRAW(I),YRAW(I),ZRAW(I)
 9028 FORMAT('I,XRAW(I),YRAW(I),ZRAW(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9027 CONTINUE
 9029 CONTINUE
      WRITE(ICOUT,9030)ISORSW
 9030 FORMAT('ISORSW = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9034)ICH2PA
 9034 FORMAT('ICH2PA= ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9035)ICH2FO
 9035 FORMAT('ICH2FO= ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9036)ICH2JU
 9036 FORMAT('ICH2JU= ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9037)ICH2DI
 9037 FORMAT('ICH2DI= ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9038)ACH2AN
 9038 FORMAT('ACH2AN= ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9039)ICH2FI
 9039 FORMAT('ICH2FI= ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9040)ICH2CO
 9040 FORMAT('ICH2CO= ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9041)PCH2HE
 9041 FORMAT('PCH2HE= ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9042)PCH2WI
 9042 FORMAT('PCH2WI= ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9043)PCH2TH,PCH2HO,PCH2VO
 9043 FORMAT('PCH2TH,PCH2HO,PCH2VO= ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9044)ITEXSP
 9044 FORMAT('ITEXSP = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9045)PXMIN,PXMAX,PYMIN,PYMAX
 9045 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9046)FX1MIN,FX1MAX,FY1MIN,FY1MAX
 9046 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9047)FXMIN,FXMAX,FYMIN,FYMAX
 9047 FORMAT('FXMIN,FXMAX,FYMIN,FYMAX= ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9048)IX1TSC,IY1TSC
 9048 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9051)ISYMBL,ISPAC
 9051 FORMAT('ISYMBL,ISPAC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9059)IBUGG4,ISUBG4,IERRG4
 9059 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE D3DRFL(ICASPL,ICAS3D,FRAM3D,
     1X3DMIN,X3DMAX,Y3DMIN,Y3DMAX,Z3DMIN,Z3DMAX,
     1IX1FSW,IX2FSW,IY1FSW,IY2FSW,
     1IX1FPA,IX2FPA,IY1FPA,IY2FPA,
     1IX1FCO,IX2FCO,IY1FCO,IY2FCO,
     1PFRATH)
C     PURPOSE--DRAW THE 3 TO 8 (IF CALLED FOR) 3-D FRAME LINES
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--93.10
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--SEPTEMBER 1993.
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ICAS3D
C
      CHARACTER*4 FRAM3D
C
      CHARACTER*4 IX1FSW
      CHARACTER*4 IX2FSW
      CHARACTER*4 IY1FSW
      CHARACTER*4 IY2FSW
C
      CHARACTER*4 IX1FPA
      CHARACTER*4 IX2FPA
      CHARACTER*4 IY1FPA
      CHARACTER*4 IY2FPA
C
      CHARACTER*4 IX1FCO
      CHARACTER*4 IX2FCO
      CHARACTER*4 IY1FCO
      CHARACTER*4 IY2FCO
C
      CHARACTER*4 IFIG
      CHARACTER*4 IPATT
      CHARACTER*4 ICOL
      CHARACTER*4 IFLAG
C
      DIMENSION PX(100)
      DIMENSION PY(100)
      DIMENSION PZ(100)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRFL')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF D3DRFL--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)X3DMIN,X3DMAX
   52 FORMAT('X3DMIN,X3DMAX = ',2F10.5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)Y3DMIN,Y3DMAX
   53 FORMAT('Y3DMIN,Y3DMAX = ',2F10.5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)Z3DMIN,Z3DMAX
   54 FORMAT('Z3DMIN,Z3DMAX = ',2F10.5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)ICASPL,ICAS3D,FRAM3D
   55 FORMAT('ICASPL,ICAS3D,FRAM3D = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)IX1FSW,IX2FSW,IY1FSW,IY2FSW
   61 FORMAT('IX1FSW,IX2FSW,IY1FSW,IY2FSW = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)IX1FPA,IX2FPA,IY1FPA,IY2FPA
   62 FORMAT('IX1FPA,IX2FPA,IY1FPA,IY2FPA = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,63)IX1FCO,IX2FCO,IY1FCO,IY2FCO
   63 FORMAT('IX1FCO,IX2FCO,IY1FCO,IY2FCO = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,64)PFRATH
   64 FORMAT('PFRATH = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,65)IBUGG4,ISUBG4,IERRG4
   65 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
      IF(ICASPL.EQ.'PIEC')GOTO9000
      IF(ICASPL.EQ.'STAR')GOTO9000
C
      IFIG='LINE'
      PTHICK=PFRATH
C
C               *********************************************
C               **  STEP 1--                               **
C               **  IF CALLED FOR,                         **
C               **  DRAW OUT THE "3 PRONG" FRAME           **
C               *********************************************
C
      IF(FRAM3D.EQ.'3PRO')THEN
         PX(1)=X3DMIN
         PX(2)=X3DMAX
         PX(3)=X3DMIN
         PX(4)=X3DMIN
         PX(5)=X3DMIN
         PX(6)=X3DMIN
C
         PY(1)=Y3DMIN
         PY(2)=Y3DMIN
         PY(3)=Y3DMIN
         PY(4)=Y3DMIN
         PY(5)=Y3DMIN
         PY(6)=Y3DMAX
C
         PZ(1)=Z3DMIN
         PZ(2)=Z3DMIN
         PZ(3)=Z3DMIN
         PZ(4)=Z3DMAX
         PZ(5)=Z3DMIN
         PZ(6)=Z3DMIN
         NP=6
         IPATT=IX1FPA
         ICOL=IX1FCO
         IFLAG='ON'
C
         CALL D3TR32(PX,PY,PZ,NP,PX,PY,NP)
         CALL D3SCAL(PX,PY,NP)
         CALL DPDRPL(PX,PY,NP,
     1   IFIG,IPATT,PTHICK,ICOL,
     1   JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
      ENDIF
C
C               *********************************************
C               **  STEP 2--                               **
C               **  IF CALLED FOR,                         **
C               **  DRAW OUT THE "3 PLANE" STYLE FRAME     **
C               *********************************************
C
      IF(FRAM3D.EQ.'3PLA')THEN
         PX(1)=X3DMIN
         PX(2)=X3DMAX
         PX(3)=X3DMAX
         PX(4)=X3DMIN
         PX(5)=X3DMIN
         PX(6)=X3DMIN
         PX(7)=X3DMIN
         PX(8)=X3DMIN
         PX(9)=X3DMIN
         PX(10)=X3DMAX
         PX(11)=X3DMAX
         PX(12)=X3DMIN
         PX(13)=X3DMIN
C
         PY(1)=Y3DMIN
         PY(2)=Y3DMIN
         PY(3)=Y3DMIN
         PY(4)=Y3DMIN
         PY(5)=Y3DMIN
         PY(6)=Y3DMAX
         PY(7)=Y3DMAX
         PY(8)=Y3DMIN
         PY(9)=Y3DMIN
         PY(10)=Y3DMIN
         PY(11)=Y3DMAX
         PY(12)=Y3DMAX
         PY(13)=Y3DMIN
C
         PZ(1)=Z3DMIN
         PZ(2)=Z3DMIN
         PZ(3)=Z3DMAX
         PZ(4)=Z3DMAX
         PZ(5)=Z3DMIN
         PZ(6)=Z3DMIN
         PZ(7)=Z3DMAX
         PZ(8)=Z3DMAX
         PZ(9)=Z3DMIN
         PZ(10)=Z3DMIN
         PZ(11)=Z3DMIN
         PZ(12)=Z3DMIN
         PZ(13)=Z3DMIN
         NP=13
         IPATT=IX1FPA
         ICOL=IX1FCO
         IFLAG='ON'
         CALL D3TR32(PX,PY,PZ,NP,PX,PY,NP)
         CALL D3SCAL(PX,PY,NP)
         CALL DPDRPL(PX,PY,NP,
     1   IFIG,IPATT,PTHICK,ICOL,
     1   JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
      ENDIF
C
C               *********************************************
C               **  STEP 3--                               **
C               **  IF CALLED FOR,                         **
C               **  DRAW OUT THE "BOX" STYLE FRAME         **
C               *********************************************
C
      IF(FRAM3D.EQ.'BOX')THEN
         PX(1)=X3DMIN
         PX(2)=X3DMAX
         PX(3)=X3DMAX
         PX(4)=X3DMIN
         PX(5)=X3DMIN
         PX(6)=X3DMIN
         PX(7)=X3DMIN
         PX(8)=X3DMIN
         PX(9)=X3DMIN
         PX(10)=X3DMAX
         PX(11)=X3DMAX
         PX(12)=X3DMAX
         PX(13)=X3DMAX
         PX(14)=X3DMAX
         PX(15)=X3DMIN
         PX(16)=X3DMAX
         PX(17)=X3DMAX
         PX(18)=X3DMIN
         PX(19)=X3DMIN
C
         PY(1)=Y3DMIN
         PY(2)=Y3DMIN
         PY(3)=Y3DMIN
         PY(4)=Y3DMIN
         PY(5)=Y3DMIN
         PY(6)=Y3DMAX
         PY(7)=Y3DMAX
         PY(8)=Y3DMIN
         PY(9)=Y3DMIN
         PY(10)=Y3DMIN
         PY(11)=Y3DMAX
         PY(12)=Y3DMAX
         PY(13)=Y3DMIN
         PY(14)=Y3DMAX
         PY(15)=Y3DMAX
         PY(16)=Y3DMAX
         PY(17)=Y3DMAX
         PY(18)=Y3DMAX
         PY(19)=Y3DMIN
C
         PZ(1)=Z3DMIN
         PZ(2)=Z3DMIN
         PZ(3)=Z3DMAX
         PZ(4)=Z3DMAX
         PZ(5)=Z3DMIN
         PZ(6)=Z3DMIN
         PZ(7)=Z3DMAX
         PZ(8)=Z3DMAX
         PZ(9)=Z3DMIN
         PZ(10)=Z3DMIN
         PZ(11)=Z3DMIN
         PZ(12)=Z3DMAX
         PZ(13)=Z3DMAX
         PZ(14)=Z3DMAX
         PZ(15)=Z3DMAX
         PZ(16)=Z3DMAX
         PZ(17)=Z3DMIN
         PZ(18)=Z3DMIN
         PZ(19)=Z3DMIN
         NP=19
         IPATT=IX1FPA
         ICOL=IX1FCO
         IFLAG='ON'
         CALL D3TR32(PX,PY,PZ,NP,PX,PY,NP)
         CALL D3SCAL(PX,PY,NP)
         CALL DPDRPL(PX,PY,NP,
     1   IFIG,IPATT,PTHICK,ICOL,
     1   JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
      ENDIF
C
C               *********************************************
C               **  STEP 4--                               **
C               **  IF CALLED FOR,                         **
C               **  DRAW OUT THE "ZIGZAG" FRAME           **
C               *********************************************
C
      IF(FRAM3D.EQ.'ZIGZ')THEN
         PX(1)=X3DMIN
         PX(2)=X3DMIN
         PX(3)=X3DMAX
         PX(4)=X3DMAX
C
         PY(1)=Y3DMAX
         PY(2)=Y3DMAX
         PY(3)=Y3DMAX
         PY(4)=Y3DMIN
C
         PZ(1)=Z3DMAX
         PZ(2)=Z3DMIN
         PZ(3)=Z3DMIN
         PZ(4)=Z3DMIN
         NP=4
         IPATT=IX1FPA
         ICOL=IX1FCO
         IFLAG='ON'
         CALL D3TR32(PX,PY,PZ,NP,PX,PY,NP)
         CALL D3SCAL(PX,PY,NP)
         CALL DPDRPL(PX,PY,NP,
     1   IFIG,IPATT,PTHICK,ICOL,
     1   JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRFL')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF D3DRFL--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)X3DMIN,X3DMAX
 9012 FORMAT('X3DMIN,X3DMAX = ',2F10.5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)Y3DMIN,Y3DMAX
 9013 FORMAT('Y3DMIN,Y3DMAX = ',2F10.5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)Z3DMIN,Z3DMAX
 9014 FORMAT('Z3DMIN,Z3DMAX = ',2F10.5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)ICASPL,ICAS3D,FRAM3D
 9015 FORMAT('ICASPL,ICAS3D,FRAM3D = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)IX1FSW,IX2FSW,IY1FSW,IY2FSW
 9021 FORMAT('IX1FSW,IX2FSW,IY1FSW,IY2FSW = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)IX1FPA,IX2FPA,IY1FPA,IY2FPA
 9022 FORMAT('IX1FPA,IX2FPA,IY1FPA,IY2FPA = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9023)IX1FCO,IX2FCO,IY1FCO,IY2FCO
 9023 FORMAT('IX1FCO,IX2FCO,IY1FCO,IY2FCO = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9024)PFRATH
 9024 FORMAT('PFRATH = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9025)IBUGG4,ISUBG4,IERRG4
 9025 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE D3DRFR(ICASPL,ICAS3D,FRAM3D,
     1X3DMIN,X3DMAX,Y3DMIN,Y3DMAX,Z3DMIN,Z3DMAX,
     1IVGMSW,IHGMSW)
C
C     PURPOSE--DRAW 3-D FRAME LINES (ALONG WITH TIC MARKS,
C              TIC MARK LABELS, AND GRID LINES
C              FOR A PLOT.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--93.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--SEPTEMBER 1993.
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ICAS3D
C
      CHARACTER*4 FRAM3D
C
      CHARACTER*4 IVGMSW
      CHARACTER*4 IHGMSW
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOPC.INC'
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRFR')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF D3DRFR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IMANUF,IMODEL
   52 FORMAT('IMANUF,IMODEL = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)ICASPL,ICAS3D
   53 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)IBUGG4,ISUBG4,IERRG4
   55 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               *******************************
C               **  STEP 1--                 **
C               **  FILL  THE MARGIN REGION  **
C               *******************************
C
      IF(IERASW.EQ.'ON'.AND.IMARCO.NE.IBACCO)
     1CALL DPFIMA(PXMIN,PYMIN,PXMAX,PYMAX,
     1ICASPL,ICAS3D,
     1IMARCO)
C
C               ****************************
C               **  STEP 2--              **
C               **  DRAW THE FRAME LINES  **
C               ****************************
C
      CALL D3DRFL(ICASPL,ICAS3D,FRAM3D,
     1X3DMIN,X3DMAX,Y3DMIN,Y3DMAX,Z3DMIN,Z3DMAX,
     1IX1FSW,IX2FSW,IY1FSW,IY2FSW,
     1IX1FPA,IX2FPA,IY1FPA,IY2FPA,
     1IX1FCO,IX2FCO,IY1FCO,IY2FCO,
     1PFRATH)
C
C               **************************
C               **  STEP 3--            **
C               **  DRAW THE TIC MARKS  **
C               **************************
C
      CALL DPDRTM(PXMIN,PYMIN,PXMAX,PYMAX,
     1ICASPL,ICAS3D,
     1IX1FSW,IX2FSW,IY1FSW,IY2FSW,
     1IX1TSW,IX2TSW,IY1TSW,IY2TSW,
     1PX1COO,PX2COO,PY1COO,PY2COO,
     1NX1COO,NX2COO,NY1COO,NY2COO,
     1PX1CMN,PX2CMN,PY1CMN,PY2CMN,
     1NX1CMN,NX2CMN,NY1CMN,NY2CMN,
     1PX1TLE,PX2TLE,PY1TLE,PY2TLE,
     1PTICTH,PMNTFA,
     1IX1TJU,IX2TJU,IY1TJU,IY2TJU,
     1IX1TCO,IX2TCO,IY1TCO,IY2TCO)
C
C               *************************************
C               **  STEP 4--                       **
C               **  WRITE OUT THE TIC MARK LABELS  **
C               *************************************
C
      CALL DPWRTL(ICASPL,ICAS3D)
C
C               ***************************
C               **  STEP 5--             **
C               **  DRAW THE GRID LINES  **
C               ***************************
C
      CALL DPDRGL(PXMIN,PYMIN,PXMAX,PYMAX,
     1ICASPL,ICAS3D,
     1IVGRSW,IHGRSW,
     1IVGMSW,IHGMSW,
     1PX1COO,PX2COO,PY1COO,PY2COO,
     1X1COOR,X2COOR,Y1COOR,Y2COOR,
     1NX1COO,NX2COO,NY1COO,NY2COO,
     1PX1CMN,PX2CMN,PY1CMN,PY2CMN,
     1X1COMN,X2COMN,Y1COMN,Y2COMN,
     1NX1CMN,NX2CMN,NY1CMN,NY2CMN,
     1IVGRPA,IHGRPA,IVGRCO,IHGRCO,
     1PVGRTH,PHGRTH,
     1PX1TOL,PX1TOR,PY1TOB,PY1TOT)
CCCC ABOVE LINE ADDED MAY, 1990 (FOR TIC OFFSETS)
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRFR')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF D3DRFR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IMANUF,IMODEL
 9012 FORMAT('IMANUF,IMODEL = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)ICASPL,ICAS3D
 9013 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)IBUGG4,ISUBG4,IERRG4
 9015 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE D3DRSP(XRAW,YRAW,ZRAW,NP,
     1PX,PY,PZ,PX2,PY2,PZ2,PX3,PY3,
     1ICASPL,ICAS3D,
     1ISORSW,
     1ISP2LI,ISP2CO,ISP2DI,PSP2TH,ASP2BA,
     1PXMIN,PXMAX,PYMIN,PYMAX,
     1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1IX1TSC,IY1TSC)
C
C     PURPOSE--FOR A GENERAL GRAPHICS DEVICE,
C              AND FOR EACH VALUE IN X(.), DRAW A SPIKE
C              (= A VERTICAL OR HORIZONTAL LINE SEGMENT)
C              FROM THE BASE POINT ASP2BA
C              TO THE POINT Y(.).
C              DO SO FOR A SPECIFIED SPIKE LINE TYPE,
C              LINES COLOR, LINE DIRECTION, AND LINE THICKNESS.
C     NOTE--THE VARIABLES PY(.) AND PX(.) ARE DUMMY VARIABLES
C           WHICH ARE USED IN THE INTERMEDIATE CALCULATIONS
C           AND WHOSE DIMENSIONS ARE DEFINED (FOR EASY OF CHANGE)
C           BACK IN THE MAIN ROUTINE.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C     UPDATED--APRIL     1987.
C     UPDATED         --SEPTEMBER 1988.  RENUMBER
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ICAS3D
C
      CHARACTER*4 ISORSW
C
      CHARACTER*4 ISP2LI
      CHARACTER*4 ISP2CO
      CHARACTER*4 ISP2DI
C
      CHARACTER*4 IX1TSC
      CHARACTER*4 IY1TSC
C
      CHARACTER*4 ITYPE
C
      CHARACTER*4 IFIG
      CHARACTER*4 IPATTT
      CHARACTER*4 ICOL
      CHARACTER*4 IDIR
C
C     6/23/86
C     HOW COME THE FOLLOWING 4 VARIABLES ARE NOT CARRIED
C     AS INPUT TO THIS SUBROUTINE--NOT NEEDED???
C     CHECK ON THIS.
C
      CHARACTER*4 IHORPA
      CHARACTER*4 IVERPA
      CHARACTER*4 IDUPPA
      CHARACTER*4 IDDOPA
C
      DIMENSION XRAW(*)
      DIMENSION YRAW(*)
      DIMENSION ZRAW(*)
      DIMENSION PX(*)
      DIMENSION PY(*)
      DIMENSION PZ(*)
      DIMENSION PX2(*)
      DIMENSION PY2(*)
      DIMENSION PZ2(*)
      DIMENSION PX3(*)
      DIMENSION PY3(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCO3D.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      HOLD=1.0
      ABASE=0.0
      PBASE=0.0
      PBASE2=0.0
C
      FXMIN=FX1MIN
      FXMAX=FX1MAX
      FYMIN=FY1MIN
      FYMAX=FY1MAX
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRSP')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF D3DRSP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)NP
   52 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)ICASPL,ICAS3D
   53 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      IF(NP.LE.3)GOTO69
      DO65I=1,3
      WRITE(ICOUT,66)I,XRAW(I),YRAW(I),ZRAW(I)
   66 FORMAT('I,XRAW(I),YRAW(I),ZRAW(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
      NPM2=NP-2
      DO67I=NPM2,NP
      WRITE(ICOUT,68)I,XRAW(I),YRAW(I),ZRAW(I)
   68 FORMAT('I,XRAW(I),YRAW(I),ZRAW(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
   67 CONTINUE
   69 CONTINUE
      WRITE(ICOUT,70)ISORSW
   70 FORMAT('ISORSW = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)ISP2LI
   71 FORMAT('ISP2LI= ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,72)ISP2CO,ISP2DI
   72 FORMAT('ISP2CO,ISP2DI= ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,73)PSP2TH
   73 FORMAT('PSP2TH= ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,74)ASP2BA
   74 FORMAT('ASP2BA= ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,84)PXMIN,PXMAX,PYMIN,PYMAX
   84 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,85)FX1MIN,FX1MAX,FY1MIN,FY1MAX
   85 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,86)IX1TSC,IY1TSC
   86 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,89)IBUGG4,ISUBG4,IERRG4
   89 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               *************************************************
C               **  STEP 11--                                  **
C               **  IF CALLED FOR, SORT THE DATA               **
C               **  ACCORDING TO THE HORIZONTAL AXIS VARIABLE  **
C               *************************************************
C
      IDIR=ISP2DI
C
      IF(ISORSW.EQ.'OFF')GOTO1150
      IF(ICASPL.EQ.'PIEC')GOTO1150
      IF(ICAS3D.EQ.'ON')GOTO1150
      IF(ICASPL.EQ.'CONT')GOTO1150
C
      CALL SORTC2(X,Y,NP,PX,PY)
      GOTO1190
C
 1150 CONTINUE
      DO1160I=1,NP
      PX(I)=XRAW(I)
      PY(I)=YRAW(I)
      PZ(I)=ZRAW(I)
 1160 CONTINUE
      GOTO1190
C
 1190 CONTINUE
C
C               ************************************************
C               **  STEP 12--                                 **
C               **  IF A LOG SCALE PLOT IS CALLED FOR,        **
C               **  CHECK THAT ALL DATA POINTS ARE POSITIVE.  **
C               ************************************************
C
      IF(IX1TSC.EQ.'LOG')GOTO1210
      GOTO1290
C
 1210 CONTINUE
      IF(IDIR.EQ.'H')GOTO1215
      GOTO1219
 1215 CONTINUE
      IF(ASP2BA.LE.0.0)HOLD=ASP2BA
      IF(ASP2BA.LE.0.0)GOTO1250
 1219 CONTINUE
C
      IF(ISORSW.EQ.'ON')GOTO1220
      GOTO1230
C
 1220 CONTINUE
      J=1
      IF(PX(J).LE.0.0)GOTO1250
      GOTO1290
C
 1230 CONTINUE
      DO1235I=1,NP
      J=I
      IF(PX(J).LE.0.0)GOTO1250
 1235 CONTINUE
      GOTO1290
C
 1250 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1251)
 1251 FORMAT('***** ERROR IN D3DRSP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1252)
 1252 FORMAT('      THE LOG OF A NON-POSITIVE DATA VALUE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1253)
 1253 FORMAT('      WAS ENCOUNTERED IN FORMING A PLOT.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1254)
 1254 FORMAT('      DATA MAY NOT BE ZERO OR NEGATIVE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1255)
 1255 FORMAT('      WHEN A LOG SCALE PLOT IS USED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1256)PX(J)
 1256 FORMAT('      THE VALUE = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1257)
 1257 FORMAT('      THIS VALUE CAME FROM THE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1258)
 1258 FORMAT('      HORIZONTAL AXIS VARIABLE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1259)
 1259 FORMAT('      CORRECTIVE ACTION--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1260)
 1260 FORMAT('      CHANGE DATA OR CHANGE LIMITS.')
      CALL DPWRST('XXX','BUG ')
      IERRG4='YES'
      GOTO9000
C
 1290 CONTINUE
C
      IF(IY1TSC.EQ.'LOG')GOTO1310
      GOTO1390
C
 1310 CONTINUE
      IF(IDIR.EQ.'V')GOTO1315
      GOTO1319
 1315 CONTINUE
      IF(ASP2BA.LE.0.0)HOLD=ASP2BA
      IF(ASP2BA.LE.0.0)GOTO1350
 1319 CONTINUE
C
      IF(ISORSW.EQ.'ON')GOTO1320
      GOTO1330
C
 1320 CONTINUE
      J=1
      IF(PY(J).LE.0.0)HOLD=PY(J)
      IF(PY(J).LE.0.0)GOTO1350
      GOTO1390
C
 1330 CONTINUE
      DO1335I=1,NP
      J=I
      IF(PY(J).LE.0.0)HOLD=PY(J)
      IF(PY(J).LE.0.0)GOTO1350
 1335 CONTINUE
      GOTO1390
C
 1350 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1351)
 1351 FORMAT('***** ERROR IN D3DRSP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1352)
 1352 FORMAT('      THE LOG OF A NON-POSITIVE DATA VALUE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1353)
 1353 FORMAT('      WAS ENCOUNTERED IN FORMING A PLOT.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1354)
 1354 FORMAT('      DATA MAY NOT BE ZERO OR NEGATIVE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1355)
 1355 FORMAT('      WHEN A LOG SCALE PLOT IS USED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1356)HOLD
 1356 FORMAT('      THE VALUE = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1357)
 1357 FORMAT('      THIS VALUE CAME FROM THE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1358)
 1358 FORMAT('      VERTICAL AXIS VARIABLE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1359)
 1359 FORMAT('      CORRECTIVE ACTION--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1360)
 1360 FORMAT('      CHANGE DATA OR CHANGE LIMITS.')
      CALL DPWRST('XXX','BUG ')
      IERRG4='YES'
      GOTO9000
C
 1390 CONTINUE
C
C               ******************************************
C               **  STEP 40--                           **
C               **  IF A LOG SCALE PLOT IS CALLED FOR,  **
C               **  TRANSFORM THE DATA                  **
C               ******************************************
C
      ABASE=ASP2BA
C
      IF(IX1TSC.EQ.'LOG')GOTO4010
      GOTO4019
 4010 CONTINUE
      IF(IDIR.EQ.'H')ABASE=ALOG10(ABASE)
      DO4015I=1,NP
      PX(I)=ALOG10(PX(I))
 4015 CONTINUE
 4019 CONTINUE
C
      IF(IY1TSC.EQ.'LOG')GOTO4020
      GOTO4029
 4020 CONTINUE
      IF(IDIR.EQ.'V')ABASE=ALOG10(ABASE)
      DO4025I=1,NP
      PY(I)=ALOG10(PY(I))
 4025 CONTINUE
 4029 CONTINUE
C
C               *******************************
C               **  STEP 60--                **
C               **  PREPARE TO MAKE VARIOUS  **
C               **  LINE SETTINGS            **
C               *******************************
C
      ITYPE='LINE'
C
C               **********************************************
C               **  STEP 61--                               **
C               **  TRANSLATE THE CHARACTER REPRESENTATION  **
C               **  OF THE LINE PATTERN                     **
C               **  INTO A NUMERIC REPRESENTATION           **
C               **  WHICH CAN BE UNDERSTOOD BY THE          **
C               **  GRAPHICS DEVICE.                        **
C               **********************************************
C
      IPATTT=ISP2LI
      CALL GRTRPA(ITYPE,IPATTT,PXSPA,PYSPA,
     1JPATTT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2)
C
C               *******************************
C               **  STEP 62--                **
C               **  SET THE LINE PATTERN     **
C               **  ON THE GRAPHICS DEVICE.  **
C               *******************************
C
      CALL GRSEPA(ITYPE,IPATTT,PXSPA,PYSPA,
     1JPATTT,IHORPA,IVERPA,IDUPPA,IDDOPA,PXSPA2,PYSPA2)
C
C               **********************************************
C               **  STEP 63--                               **
C               **  TRANSLATE THE  DESIRED                  **
C               **  LINE THICKNESS                          **
C               **  INTO A NUMERIC REPRESENTATION           **
C               **  WHICH CAN BE UNDERSTOOD BY THE          **
C               **  GRAPHICS DEVICE.                        **
C               **********************************************
C
      PTHICK=PSP2TH
      CALL GRTRTH(ITYPE,PTHICK,JTHICK,PTHIC2)
C
C               *******************************
C               **  STEP 64--                **
C               **  SET THE LINE THICKNESS   **
C               **  ON THE GRAPHICS DEVICE.  **
C               *******************************
C
      CALL GRSETH(ITYPE,PTHICK,JTHICK,PTHIC2)
C
C               **********************************************
C               **  STEP 65--                               **
C               **  TRANSLATE THE CHARACTER REPRESENTATION  **
C               **  OF THE LINE COLOR                       **
C               **  INTO A NUMERIC REPRESENTATION           **
C               **  WHICH CAN BE UNDERSTOOD BY THE          **
C               **  GRAPHICS DEVICE.                        **
C               **********************************************
C
      ICOL=ISP2CO
      CALL GRTRCO(ITYPE,ICOL,JCOL)
C
C               *******************************
C               **  STEP 66--                **
C               **  SET THE LINE COLOR       **
C               **  ON THE GRAPHICS DEVICE.  **
C               *******************************
C
      CALL GRSECO(ITYPE,ICOL,JCOL)
C
C               **************************************************
C               **  STEP 71--                                   **
C               **  FOR EACH RAW 3-D DATA POINT--               **
C               **     1) MAKE THE SPIKE                        **
C               **     2) TRANSLATE IT TO 2 DIMENSIONS          **
C               **     3) TRANSLATE IT TO 0-100 UNITS           **
C               **     4) CLIP THE SPIKE IF NEEDED              **
C               **     5) DRAW OUT THE SPIKE                    **
C               **************************************************
C
C
      IFIG='GENE'
C
      FXMIN=FX1MIN
      FXMAX=FX1MAX
      IF(IX1TSC.EQ.'LOG')FXMIN=ALOG10(FX1MIN)
      IF(IX1TSC.EQ.'LOG')FXMAX=ALOG10(FX1MAX)
C
      FYMIN=FY1MIN
      FYMAX=FY1MAX
      IF(IY1TSC.EQ.'LOG')FYMIN=ALOG10(FY1MIN)
      IF(IY1TSC.EQ.'LOG')FYMAX=ALOG10(FY1MAX)
C
      FXRANG=FXMAX-FXMIN
      FYRANG=FYMAX-FYMIN
      PXRANG=PXMAX-PXMIN
      PYRANG=PYMAX-PYMIN
C
      DO7100I=1,NP
C
      CALL D3MKSP(PX,PY,PZ,NP,I,
     1IDIR,
     1ABASE,ABASE,ABASE,
     1PX2,PY2,PZ2,NP2)
C
      CALL D3TR32(PX2,PY2,PZ2,NP2,PX3,PY3,NP3)
C
      CALL D3TRXP(PX3,PY3,NP3,IDIR,ABASE,
     1FXMIN,FXMAX,FXRANG,FYMIN,FYMAX,FYRANG,
     1PXMIN,PXMAX,PXRANG,PYMIN,PYMAX,PYRANG,
     1PX3,PY3,NP3,PBASE)
C
      CALL DPSQUE(PX3,PY3,NP3,
     1PXMIN,PXMAX,PYMIN,PYMAX)
C
      CALL GRDRPL(PX3,PY3,NP3,
     1IFIG,IPATTT,PTHICK,ICOL,
     1JPATTT,JTHICK,PTHIC2,JCOL)
C
 7100 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRSP')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF D3DRSP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)NP
 9012 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)ICASPL,ICAS3D
 9013 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)HOLD
 9014 FORMAT('HOLD = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)ABASE,PBASE,PBASE2
 9015 FORMAT('ABASE,PBASE,PBASE2 = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(NP.LE.3)GOTO9029
      DO9025I=1,3
      WRITE(ICOUT,9026)I,XRAW(I),YRAW(I),ZRAW(I)
 9026 FORMAT('I,XRAW(I),YRAW(I),ZRAW(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9025 CONTINUE
      NPM2=NP-2
      DO9027I=NPM2,NP
      WRITE(ICOUT,9028)I,XRAW(I),YRAW(I),ZRAW(I)
 9028 FORMAT('I,XRAW(I),YRAW(I),ZRAW(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9027 CONTINUE
 9029 CONTINUE
      WRITE(ICOUT,9030)ISORSW
 9030 FORMAT('ISORSW = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)ISP2LI
 9031 FORMAT('ISP2LI= ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)PSP2TH
 9032 FORMAT('PSP2TH= ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9033)ISP2CO,ISP2DI
 9033 FORMAT('ISP2CO,ISP2DI= ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9044)PXMIN,PXMAX,PYMIN,PYMAX
 9044 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9045)FX1MIN,FX1MAX,FY1MIN,FY1MAX
 9045 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9046)FXMIN,FXMAX,FYMIN,FYMAX
 9046 FORMAT('FXMIN,FXMAX,FYMIN,FYMAX= ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9047)IX1TSC,IY1TSC
 9047 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9051)IFIG
 9051 FORMAT('IFIG = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9052)IPATTT,JPATTT
 9052 FORMAT('IPATTT,JPATTT = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9053)PTHICK,JTHICK,PTHIC2
 9053 FORMAT('PTHICK,JTHICK,PTHIC2 = ',E15.7,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9054)ICOL,JCOL,IDIR
 9054 FORMAT('ICOL,JCOL,IDIR = ',A4,I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9055)ITYPE
 9055 FORMAT('ITYPE = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9069)IBUGG4,ISUBG4,IERRG4
 9069 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9071)NP2,NP3
 9071 FORMAT('NP2,NP3 = ',2I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE D3DRTR(XRAW,YRAW,ZRAW,PX,PY,PZ,NP,PY2,PX2,NP2,
     1PY3,PX3,NP3,
     1ICASPL,ICAS3D,
     1ISORSW,
     1ILI2PA,ILI2CO,PLI2TH,
     1ARE2BA,
     1IRE2FS,IRE2FC,
     1IRE2PT,IRE2PL,IRE2PC,PRE2PT,PRE2PS,
     1PXMIN,PXMAX,PYMIN,PYMAX,
     1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1IX1TSC,IY1TSC)
C
C     PURPOSE--FOR A GENERAL GRAPHICS DEVICE,
C              DRAW A SINGLE TRACE OF Y(.) VERSUS X(.)
C              FOR A SPECIFIED LINE TYPE, COLOR, AND THICKNESS.
C              AND (IF CALLED FOR) FILL IN BELOW/ABOVE THE TRACE
C              TO THE BASE LINE ARE2BA.
C     NOTE--THE VARIABLES PY(.) AND PX(.) ARE DUMMY VARIABLES
C           WHICH ARE USED IN THE INTERMEDIATE CALCULATIONS
C           AND WHOSE DIMENSIONS ARE DEFINED (FOR EASY OF CHANGE)
C           BACK IN THE MAIN ROUTINE.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C     UPDATED         --FEBRUARY  1988.   STAR PLOT
C     UPDATED         --SEPTEMBER 1988.  LOG/WEIBULL CHECK AS A SUBROUTINE
C     UPDATED         --SEPTEMBER 1988.  RENUMBER
C     UPDATED         --AUGUST    1992.  CALL TO DPFIRE
C     UPDATED         --JULY      1993.  NORMAL SCALE (JJF)
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ICAS3D
C
      CHARACTER*4 ISORSW
C
      CHARACTER*4 ILI2PA
      CHARACTER*4 ILI2CO
C
      CHARACTER*4 IRE2FS
      CHARACTER*4 IRE2FC
      CHARACTER*4 IRE2PT
      CHARACTER*4 IRE2PL
      CHARACTER*4 IRE2PC
C
      CHARACTER*4 IX1TSC
      CHARACTER*4 IY1TSC
C
      CHARACTER*4 IFIG
      CHARACTER*4 IPATT
      CHARACTER*4 ICOL
C
      CHARACTER*4 ICOLF
      CHARACTER*4 ICOLP
C
      CHARACTER*4 ICASAX
C
CCCCC AUGUST 1992.
      CHARACTER*4 IPATT2
C
      DIMENSION XRAW(*)
      DIMENSION YRAW(*)
      DIMENSION ZRAW(*)
      DIMENSION PX(*)
      DIMENSION PY(*)
      DIMENSION PZ(*)
      DIMENSION PY2(*)
      DIMENSION PX2(*)
      DIMENSION PY3(*)
      DIMENSION PX3(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCO3D.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      HOLD=1.0
      ABASE=0.0
      PBASE=0.0
      PBASE2=0.0
      PLEFT=0.0
      PRIGHT=0.0
      AWIDTH=0.0
      PWIDTH=0.0
      FYRATI=0.0
C
      FXMIN=FX1MIN
      FXMAX=FX1MAX
      FYMIN=FY1MIN
      FYMAX=FY1MAX
C
      AHUNDR=100.0
      ABASE2=0.0
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRTR')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF D3DRTR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)NP
   52 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)ICASPL,ICAS3D
   53 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      IF(NP.LE.3)GOTO69
      DO65I=1,3
      WRITE(ICOUT,66)I,XRAW(I),YRAW(I),ZRAW(I)
   66 FORMAT('I,XRAW(I),YRAW(I),ZRAW(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
      NPM2=NP-2
      DO67I=NPM2,NP
      WRITE(ICOUT,68)I,XRAW(I),YRAW(I),ZRAW(I)
   68 FORMAT('I,XRAW(I),YRAW(I),ZRAW(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
   67 CONTINUE
   69 CONTINUE
      WRITE(ICOUT,70)ISORSW
   70 FORMAT('ISORSW = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)ILI2PA,ILI2CO,PLI2TH
   71 FORMAT('ILI2PA,ILI2CO,PLI2TH = ',A4,2X,A4,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,72)ARE2BA
   72 FORMAT('ARE2BA = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,73)IRE2FS,IRE2FC
   73 FORMAT('IRE2FS,IRE2FC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,74)IRE2PT,IRE2PL,IRE2PC,PRE2PT,PRE2PS
   74 FORMAT('IRE2PT,IRE2PL,IRE2PC,PRE2PT,PRE2PS = ',
     1A4,2X,A4,2X,A4,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,84)PXMIN,PXMAX,PYMIN,PYMAX
   84 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,85)FX1MIN,FX1MAX,FY1MIN,FY1MAX
   85 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,86)IX1TSC,IY1TSC
   86 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,89)IBUGG4,ISUBG4,IERRG4
   89 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               *************************************************
C               **  STEP 11--                                  **
C               **  IF CALLED FOR, SORT THE DATA               **
C               **  ACCORDING TO THE HORIZONTAL AXIS VARIABLE  **
C               *************************************************
C
      IF(ISORSW.EQ.'OFF')GOTO1150
      IF(ICASPL.EQ.'PIEC')GOTO1150
      IF(ICASPL.EQ.'STAR')GOTO1150
      IF(ICAS3D.EQ.'ON')GOTO1150
      IF(ICASPL.EQ.'CONT')GOTO1150
C
      CALL SORTC2(X,Y,NP,PX,PY)
      GOTO1190
C
 1150 CONTINUE
      DO1160I=1,NP
      PX(I)=XRAW(I)
      PY(I)=YRAW(I)
      PZ(I)=ZRAW(I)
 1160 CONTINUE
      GOTO1190
C
 1190 CONTINUE
C
C               **********************************************************
C               **  STEP 21--                                           **
C               **  IF A NON-LINEAR SCALE PLOT IS CALLED FOR,           **
C               **  CHECK THAT ALL   HORIZ. AXIS DATA POINTS            **
C               **  ARE IN VALID RANGE.                                 **
C               **  IF A LOG SCALE PLOT IS CALLED FOR,                  **
C               **  CHECK THAT ALL   HORIZ.  AXIS DATA POINTS ARE > 0.  **
C               **  IF A WEIBULL SCALE PLOT IS CALLED FOR,              **
C               **  CHECK THAT ALL   HORIZ. AXIS DATA POINTS ARE        **
C               **  IF A NORMAL SCALE PLOT IS CALLED FOR,              **
C               **  CHECK THAT ALL   HORIZ. AXIS DATA POINTS ARE        **
C               **  STRICTLY > 0 AND STRICTLY < 100                     **
C               **********************************************************
C
      IF(IX1TSC.EQ.'LOG')GOTO2110
      GOTO2119
 2110 CONTINUE
      ICASAX='2DHO'
      CALL CKLOSC(PX,NP,ISORSW,ICASAX,
     1ISUBG4,IBUGG4,IERRG4)
      IF(IERRG4.EQ.'YES')GOTO9000
 2119 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS CHANGED JULY 1993 (JJF)
CCCCC IF(IX1TSC.EQ.'WEIB')GOTO2120
      IF(IX1TSC.EQ.'WEIB'.OR.
     1   IX1TSC.EQ.'NORM')GOTO2120
      GOTO2129
 2120 CONTINUE
      ICASAX='2DHO'
CCCCC CALL CKWESC(PX,NP,ISORSW,ICASAX,
CCCCC CALL CKPRSC(PX,NP,ISORSW,ICASAX,
CCCCC1ISUBG4,IBUGG4,IERRG4)
CCCCC IF(IERRG4.EQ.'YES')GOTO9000
 2129 CONTINUE
C
C               **********************************************************
C               **  STEP 22--                                           **
C               **  IF A NON-LINEAR SCALE PLOT IS CALLED FOR,           **
C               **  CHECK THAT ALL   VERT.  AXIS DATA POINTS            **
C               **  ARE IN VALID RANGE.                                 **
C               **  IF A LOG SCALE PLOT IS CALLED FOR,                  **
C               **  CHECK THAT ALL   VERT.   AXIS DATA POINTS ARE > 0.  **
C               **  IF A WEIBULL SCALE PLOT IS CALLED FOR,              **
C               **  CHECK THAT ALL   VERT.  AXIS DATA POINTS ARE        **
C               **  STRICTLY > 0 AND STRICTLY < 100                     **
C               **  IF A NORMAL  SCALE PLOT IS CALLED FOR,              **
C               **  CHECK THAT ALL   VERT.  AXIS DATA POINTS ARE        **
C               **  STRICTLY > 0 AND STRICTLY < 100                     **
C               **********************************************************
C
      IF(IY1TSC.EQ.'LOG')GOTO2210
      GOTO2219
 2210 CONTINUE
      ICASAX='2DVE'
      CALL CKLOSC(PY,NP,ISORSW,ICASAX,
     1ISUBG4,IBUGG4,IERRG4)
      IF(IERRG4.EQ.'YES')GOTO9000
 2219 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS CHANGED JULY 1993 (JJF)
CCCCC IF(IY1TSC.EQ.'WEIB')GOTO2220
      IF(IY1TSC.EQ.'WEIB'.OR.
     1   IY1TSC.EQ.'NORM')GOTO2220
      GOTO2229
 2220 CONTINUE
      ICASAX='2DVE'
CCCCC CALL CKWESC(PY,NP,ISORSW,ICASAX,
CCCCC CALL CKPRSC(PY,NP,ISORSW,ICASAX,
CCCCC1ISUBG4,IBUGG4,IERRG4)
CCCCC IF(IERRG4.EQ.'YES')GOTO9000
 2229 CONTINUE
C
C               ******************************************
C               **  STEP 41--                           **
C               **  IF A LOG SCALE PLOT IS CALLED FOR,  **
C               **  TRANSFORM THE DATA                  **
C               ******************************************
C
      IF(IX1TSC.EQ.'LOG')GOTO4110
      GOTO4119
 4110 CONTINUE
      DO4115I=1,NP
      PX(I)=ALOG10(PX(I))
 4115 CONTINUE
 4119 CONTINUE
C
      ABASE=ARE2BA
      IF(IY1TSC.EQ.'LOG')GOTO4120
      GOTO4129
 4120 CONTINUE
      IF(ABASE.NE.CPUMAX.AND.ABASE.GT.0.0)ABASE=ALOG10(ABASE)
      IF(ABASE.NE.CPUMAX.AND.ABASE.LE.0.0)ABASE=1.0
      DO4125I=1,NP
      PY(I)=ALOG10(PY(I))
 4125 CONTINUE
 4129 CONTINUE
C
C               ******************************************
C               **  STEP 42--                           **
C               **  IF A WEIBULL SCALE PLOT IS CALLED FOR,  **
C               **  TRANSFORM THE DATA                  **
C               ******************************************
C
      IF(IX1TSC.EQ.'WEIB')GOTO4210
      GOTO4219
 4210 CONTINUE
      DO4215I=1,NP
      PX(I)=ALOG(ALOG(AHUNDR/(AHUNDR-PX(I))))
 4215 CONTINUE
 4219 CONTINUE
C
      ABASE=ARE2BA
      IF(IY1TSC.EQ.'WEIB')GOTO4220
      GOTO4229
 4220 CONTINUE
      IF(ABASE.NE.CPUMAX.AND.ABASE.GT.0.0.AND.ABASE.LT.AHUNDR)
     1ABASE2=ALOG(ALOG(AHUNDR/(AHUNDR-ABASE)))
      IF(ABASE.NE.CPUMAX.AND.ABASE.LE.0.0)ABASE2=0.1
      IF(ABASE.NE.CPUMAX.AND.ABASE.GE.AHUNDR)ABASE2=0.1
      ABASE=ABASE2
      DO4225I=1,NP
      PY(I)=ALOG(ALOG(AHUNDR/(AHUNDR-PY(I))))
 4225 CONTINUE
 4229 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED   JULY 1993 (JJF)
C               ******************************************
C               **  STEP 43--                           **
C               **  IF A NORMAL  SCALE PLOT IS CALLED FOR,  **
C               **  TRANSFORM THE DATA                  **
C               ******************************************
C
      IF(IX1TSC.EQ.'NORM')GOTO4310
      GOTO4319
 4310 CONTINUE
      DO4315I=1,NP
CCCCC CHANGE FOLLOWING LINE NOVEMBER 1994.
CCCCC PX(I)=AHUNDR*NORCDF(PX(I))
      CALL NORCDF(PX(I),ATEMP)
      PX(I)=AHUNDR*ATEMP
 4315 CONTINUE
 4319 CONTINUE
C
      ABASE=ARE2BA
      IF(IY1TSC.EQ.'WEIB')GOTO4320
      GOTO4329
 4320 CONTINUE
      CALL NORCDF(ABASE,ATEMP)
      IF(ABASE.NE.CPUMAX.AND.ABASE.GT.0.0.AND.ABASE.LT.AHUNDR)
     1ABASE2=AHUNDR*ATEMP
      IF(ABASE.NE.CPUMAX.AND.ABASE.LE.0.0)ABASE2=0.1
      IF(ABASE.NE.CPUMAX.AND.ABASE.GE.AHUNDR)ABASE2=0.1
      ABASE=ABASE2
      DO4325I=1,NP
CCCCC CHANGE FOLLOWING LINE NOVEMBER 1994.
CCCCC PY(I)=AHUNDR*NORCDF(PY(I))
      CALL NORCDF(PY(I),ATEMP)
      PY(I)=AHUNDR*ATEMP
 4325 CONTINUE
 4329 CONTINUE
C
C               **************************************************
C               **  STEP 51--                                   **
C               **  FORM THE TRACE IN RAW 3-D SPACE.            **
C               **************************************************
C
C               **************************************************
C               **  STEP 52--                                   **
C               **  IF HIDDEN LINE REMOVAL IS ON,               **
C               **  DETERMINE IF ANY PART                       **
C               **  OF THE TRACE IS VISIBLE;                    **
C               **  FORM SUBTRACES.                             **
C               **************************************************
C
C               **************************************************
C               **  STEP 53--                                   **
C               **  TRANSLATE THE VISIBLE SUB-TRACES            **
C               **  FROM THE RAW 3-D SPACE                      **
C               **  TO THE FINAL VISUAL 2-D PLANE.              **
C               **************************************************
C
      CALL D3TR32(PX,PY,PZ,NP,PX,PY,NP)
C
C               *****************************************************
C               **  STEP 54--                                      **
C               **  TRANSLATE THE 2-D PLANE DATA POINTS            **
C               **  INTO STANDARDIZED (0.0 TO 100.0) COORDINATES.  **
C               *****************************************************
C
      FXMIN=FX1MIN
      FXMAX=FX1MAX
      IF(IX1TSC.EQ.'LOG')FXMIN=ALOG10(FX1MIN)
      IF(IX1TSC.EQ.'LOG')FXMAX=ALOG10(FX1MAX)
      IF(IX1TSC.EQ.'WEIB')FXMIN=ALOG(ALOG(AHUNDR/(AHUNDR-FX1MIN)))
      IF(IX1TSC.EQ.'WEIB')FXMAX=ALOG(ALOG(AHUNDR/(AHUNDR-FX1MAX)))
CCCCC THE FOLLOWING 2 LINES WERE ADDED JULY 193 (JJF)
CCCCC CHANGE FOLLOWING 2 LINES NOVEMBER 1994.
CCCCC IF(IX1TSC.EQ.'NORM')FXMIN=AHUNDR*NORCDF(FX1MIN)
CCCCC IF(IX1TSC.EQ.'NORM')FXMAX=AHUNDR*NORCDF(FX1MAX)
      CALL NORCDF(FX1MIN,ATEMP)
      IF(IX1TSC.EQ.'NORM')FXMIN=AHUNDR*ATEMP
      CALL NORCDF(FX1MAX,ATEMP)
      IF(IX1TSC.EQ.'NORM')FXMAX=AHUNDR*ATEMP
C
      FYMIN=FY1MIN
      FYMAX=FY1MAX
      IF(IY1TSC.EQ.'LOG')FYMIN=ALOG10(FY1MIN)
      IF(IY1TSC.EQ.'LOG')FYMAX=ALOG10(FY1MAX)
      IF(IY1TSC.EQ.'WEIB')FYMIN=ALOG(ALOG(AHUNDR/(AHUNDR-FY1MIN)))
      IF(IY1TSC.EQ.'WEIB')FYMAX=ALOG(ALOG(AHUNDR/(AHUNDR-FY1MAX)))
CCCCC THE FOLLOWING 2 LINES WERE ADDED JULY 193 (JJF)
CCCCC CHANGE FOLLOWING 2 LINES NOVEMBER 1994.
CCCCC IF(IY1TSC.EQ.'NORM')FYMIN=AHUNDR*NORCDF(FY1MIN)
CCCCC IF(IY1TSC.EQ.'NORM')FYMAX=AHUNDR*NORCDF(FY1MAX)
      CALL NORCDF(FY1MIN,ATEMP)
      IF(IY1TSC.EQ.'NORM')FYMIN=AHUNDR*ATEMP
      CALL NORCDF(FY1MAX,ATEMP)
      IF(IY1TSC.EQ.'NORM')FYMAX=AHUNDR*ATEMP
C
      FXRANG=FXMAX-FXMIN
      FYRANG=FYMAX-FYMIN
      PXRANG=PXMAX-PXMIN
      PYRANG=PYMAX-PYMIN
C
      DO5410I=1,NP
      FXRATI=(PX(I)-FXMIN)/FXRANG
      FYRATI=(PY(I)-FYMIN)/FYRANG
      PX(I)=PXMIN+FXRATI*PXRANG
      PY(I)=PYMIN+FYRATI*PYRANG
 5410 CONTINUE
      IF(ABASE.NE.CPUMAX)FYRATI=(ABASE-FYMIN)/FYRANG
      IF(ABASE.NE.CPUMAX)PBASE=PYMIN+FYRATI*PYRANG
C
C               **************************************
C               **  STEP 60--                       **
C               **  IF CALLED FOR,                  **
C               **  FILL OVER/UNDER THE TRACE       **
C               **  (BUT CLIP FIRST, IF NECESSARY)  **
C               **************************************
C
      IFIG='GENE'
C
      IF(IRE2FS.EQ.'OFF')GOTO6190
      IPATT=IRE2PT
      PTHICK=PRE2PT
      PXGAP=PRE2PS
      PYGAP=PRE2PS
      ICOLF=IRE2FC
      ICOLP=IRE2PC
CCCCC AUGUST 1992.  SET IPATT2
      IPATT2='SOLI'
C
      CALL DPSQUE(PX,PY,NP,
     1PXMIN,PXMAX,PYMIN,PYMAX)
C
      IF(ABASE.EQ.CPUMAX)GOTO6110
      GOTO6120
C
 6110 CONTINUE
      DO6115I=1,NP
      PX2(I)=PX(I)
      PY2(I)=PY(I)
 6115 CONTINUE
      NP2=NP+1
      PX2(NP2)=PX(1)
      PY2(NP2)=PY(1)
C
      DO6116J=1,NP2
      IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN
      IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX
      IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN
      IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX
 6116 CONTINUE
C
CCCCC AUGUST 1992.  ADD IPATT2
      CALL DPFIRE(PX2,PY2,NP2,
CCCCC1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP)
     1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,
     1IPATT2)
C
      GOTO6190
C
 6120 CONTINUE
      PBASE2=PBASE
      IF(PBASE2.LT.PYMIN.AND.(PYMIN-PBASE2).LE.0.0001)PBASE2=PYMIN
      IF(PBASE2.GT.PYMAX.AND.(PBASE2-PYMAX).LE.0.0001)PBASE2=PYMAX
C
      NP2=5
      NPM1=NP-1
      IF(NPM1.LE.0)GOTO6190
      DO6125I=1,NPM1
      IP1=I+1
C
      PLEFT=PX(I)
      PRIGHT=PX(IP1)
      IF(PLEFT.LT.PXMIN.AND.(PXMIN-PLEFT).LE.0.0001)PLEFT=PXMIN
      IF(PRIGHT.GT.PXMAX.AND.(PRIGHT-PXMAX).LE.0.0001)PRIGHT=PXMAX
C
      IF(PRIGHT.LT.PXMIN)GOTO6125
      IF(PLEFT.GT.PXMAX)GOTO6125
      IF(PY(I).LT.PYMIN.AND.PBASE2.LT.PYMIN)GOTO6125
      IF(PY(I).GT.PYMAX.AND.PBASE2.GT.PYMAX)GOTO6125
C
      PX2(1)=PLEFT
      PX2(2)=PRIGHT
      PX2(3)=PRIGHT
      PX2(4)=PLEFT
      PX2(5)=PLEFT
C
      PY2(1)=PBASE2
      PY2(2)=PBASE2
      PY2(3)=PY(IP1)
      PY2(4)=PY(I)
      PY2(5)=PBASE2
C
      DO6126J=1,NP2
      IF(PX2(J).LT.PXMIN)PX2(J)=PXMIN
      IF(PX2(J).GT.PXMAX)PX2(J)=PXMAX
      IF(PY2(J).LT.PYMIN)PY2(J)=PYMIN
      IF(PY2(J).GT.PYMAX)PY2(J)=PYMAX
 6126 CONTINUE
C
CCCCC AUGUST 1992.  ADD IPATT2
      CALL DPFIRE(PX2,PY2,NP2,
CCCCC1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP)
     1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,
     1IPATT2)
 6125 CONTINUE
C
      GOTO6190
C
 6190 CONTINUE
C
C               *****************************************
C               **  STEP 70--                          **
C               **  DRAW OUT THE TRACE                 **
C               **  (BUT CLIP IT FIRST, IF NECESSARY)  **
C               *****************************************
C
      IFIG='GENE'
      IPATT=ILI2PA
      PTHICK=PLI2TH
      ICOL=ILI2CO
C
      CALL DPCLTR(PX,PY,NP,PX2,PY2,NP2,PY3,PX3,NP3,
     1PXMIN,PXMAX,PYMIN,PYMAX,
     1ISORSW,
     1IFIG,IPATT,PTHICK,ICOL)
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DRTR')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF D3DRTR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)NP
 9012 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)ICASPL,ICAS3D
 9013 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      IF(NP.LE.3)GOTO9029
      DO9025I=1,3
      WRITE(ICOUT,9026)I,XRAW(I),YRAW(I),ZRAW(I)
 9026 FORMAT('I,XRAW(I),YRAW(I),ZRAW(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9025 CONTINUE
      NPM2=NP-2
      DO9027I=NPM2,NP
      WRITE(ICOUT,9028)I,XRAW(I),YRAW(I),ZRAW(I)
 9028 FORMAT('I,XRAW(I),YRAW(I),ZRAW(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9027 CONTINUE
 9029 CONTINUE
      WRITE(ICOUT,9030)ISORSW
 9030 FORMAT('ISORSW = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)ILI2PA,ILI2CO,PLI2TH
 9031 FORMAT('ILI2PA,ILI2CO,PLI2TH = ',A4,2X,A4,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)ARE2BA
 9032 FORMAT('ARE2BA = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9033)IRE2FS,IRE2FC
 9033 FORMAT('IRE2FS,IRE2FC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9034)IRE2PT,IRE2PL,IRE2PC,PRE2PT,PRE2PS
 9034 FORMAT('IRE2PT,IRE2PL,IRE2PC,PRE2PT,PRE2PS = ',
     1A4,2X,A4,2X,A4,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9044)PXMIN,PXMAX,PYMIN,PYMAX
 9044 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX= ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9045)FX1MIN,FX1MAX,FY1MIN,FY1MAX
 9045 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX= ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9046)FXMIN,FXMAX,FYMIN,FYMAX
 9046 FORMAT('FXMIN,FXMAX,FYMIN,FYMAX= ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9047)IX1TSC,IY1TSC
 9047 FORMAT('IX1TSC,IY1TSC = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9049)IBUGG4,ISUBG4,IERRG4
 9049 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE D3MKBA(XRAW,YRAW,ZRAW,NRAW,IRAW,
     1IDIR,
     1WIDTHX,WIDTHY,WIDTHZ,
     1BASEX,BASEY,BASEZ,
     1XVECT,YVECT,ZVECT,IXNEAR,IXFAR,IYNEAR,IYFAR,IZNEAR,IZFAR,
     1XBAR,YBAR,ZBAR,NBAR)
C
C     PURPOSE--GIVEN A SINGLE POINT (XRAW(IRAW),YRAW(IRAW),ZRAW(IRAW))
C              IN 3-SPACE, AND AN EYE POSITION,
C              MAKE (= CONSTRUCT) A 3-D BAR.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISIONBAR
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--88/10
C     ORIGINAL VERSION--SEPTEMBER 1988.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IDIR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
CCCCC CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION XRAW(*)
      DIMENSION YRAW(*)
      DIMENSION ZRAW(*)
C
      DIMENSION XVECT(*)
      DIMENSION YVECT(*)
      DIMENSION ZVECT(*)
C
      DIMENSION XBAR(*)
      DIMENSION YBAR(*)
      DIMENSION ZBAR(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCO3D.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='D3MK'
      ISUBN2='BA  '
C
      IF(IBUGG4.NE.'ON'.AND.ISUBG4.NE.'MKBA')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF D3MKBA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGG4,ISUBG4,IERRG4
   52 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',3A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IDIR
   53 FORMAT('IDIR = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)WIDTHX,WIDTHY,WIDTHZ
   54 FORMAT('WIDTHX,WIDTHY,WIDTHZ = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)BASEX,BASEY,BASEZ
   55 FORMAT('BASEX,BASEY,BASEZ    = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,56)X3DEYE,Y3DEYE,Z3DEYE
   56 FORMAT('X3DEYE,Y3DEYE,Z3DEYE    = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)XVECT(1),YVECT(1),ZVECT(1)
   61 FORMAT('XVECT(1),YVECT(1),ZVECT(1) = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)XVECT(2),YVECT(2),ZVECT(2)
   62 FORMAT('XVECT(2),YVECT(2),ZVECT(2) = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,63)IXNEAR,IXFAR,IYNEAR,IYFAR,IZNEAR,IZFAR
   63 FORMAT('IXNEAR,IXFAR,IYNEAR,IYFAR,IZNEAR,IZFAR = ',6I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)NRAW,IRAW
   71 FORMAT('NRAW,IRAW = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,72)IRAW,XRAW(IRAW),YRAW(IRAW),ZRAW(IRAW)
   72 FORMAT('IRAW,XRAW(IRAW),YRAW(IRAW),ZRAW(IRAW) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               **************************************************
C               **  MAKE (= CONSTRUCT) A BAR.                 **
C               **************************************************
C
C               **************************************************
C               **  STEP 11-                                    **
C               **  FIND THE NEAREST (TO THE EYE) VERTEX        **
C               **  OF OF THE 8 VERTICES OF THE 3-D BAR         **
C               **************************************************
C
      X0=XRAW(IRAW)
      Y0=YRAW(IRAW)
      Z0=ZRAW(IRAW)
C
      IF(IDIR.EQ.'V')GOTO1110
      IF(IDIR.EQ.'H1')GOTO1120
      IF(IDIR.EQ.'H2')GOTO1130
      GOTO1110
C
 1110 CONTINUE
      XVECT(1)=X0-WIDTHX/2.0
      XVECT(2)=X0+WIDTHX/2.0
      YVECT(1)=Y0-WIDTHY/2.0
      YVECT(2)=Y0+WIDTHY/2.0
      ZVECT(1)=BASEZ
      ZVECT(2)=Z0
      GOTO1150
C
 1120 CONTINUE
      XVECT(1)=BASEX
      XVECT(2)=X0
      YVECT(1)=Y0-WIDTHY/2.0
      YVECT(2)=Y0+WIDTHY/2.0
      ZVECT(1)=Z0-WIDTHZ/2.0
      ZVECT(2)=Z0+WIDTHZ/2.0
      GOTO1150
C
 1130 CONTINUE
      XVECT(1)=X0-WIDTHX/2.0
      XVECT(2)=X0+WIDTHX/2.0
      YVECT(1)=BASEY
      YVECT(2)=Y0
      ZVECT(1)=Z0-WIDTHZ/2.0
      ZVECT(2)=Z0+WIDTHZ/2.0
      GOTO1150
C
 1150 CONTINUE
C
      DISTSQ=CPUMAX
      DO1151IX=1,2
      XVECT2=XVECT(IX)
      DO1152IY=1,2
      YVECT2=YVECT(IY)
      DO1153IZ=1,2
      ZVECT2=ZVECT(IZ)
      DISTS2=(XVECT2-X3DEYE)**2+(YVECT2-Y3DEYE)**2+(ZVECT2-Z3DEYE)**2
      IF(DISTS2.LT.DISTSQ)GOTO1155
      GOTO1153
 1155 CONTINUE
      IXNEAR=IX
      IYNEAR=IY
      IZNEAR=IZ
 1153 CONTINUE
 1152 CONTINUE
 1151 CONTINUE
C
      IXFAR=1
      IF(IXNEAR.EQ.1)IXFAR=2
      IYFAR=1
      IF(IYNEAR.EQ.1)IYFAR=2
      IZFAR=1
      IF(IZNEAR.EQ.1)IZFAR=2
C
      XBAR(1)=XVECT(IXNEAR)
      XBAR(2)=XVECT(IXNEAR)
      XBAR(3)=XVECT(IXNEAR)
      XBAR(4)=XVECT(IXNEAR)
      XBAR(5)=XVECT(IXNEAR)
      YBAR(1)=YVECT(IYNEAR)
      YBAR(2)=YVECT(IYNEAR)
      YBAR(3)=YVECT(IYFAR)
      YBAR(4)=YVECT(IYFAR)
      YBAR(5)=YVECT(IYNEAR)
      ZBAR(1)=ZVECT(IZNEAR)
      ZBAR(2)=ZVECT(IZFAR)
      ZBAR(3)=ZVECT(IZFAR)
      ZBAR(4)=ZVECT(IZNEAR)
      ZBAR(5)=ZVECT(IZNEAR)
C
      XBAR(6)=XVECT(IXNEAR)
      XBAR(7)=XVECT(IXFAR)
      XBAR(8)=XVECT(IXFAR)
      XBAR(9)=XVECT(IXNEAR)
      XBAR(10)=XVECT(IXNEAR)
      YBAR(6)=YVECT(IYNEAR)
      YBAR(7)=YVECT(IYNEAR)
      YBAR(8)=YVECT(IYNEAR)
      YBAR(9)=YVECT(IYNEAR)
      YBAR(10)=YVECT(IYNEAR)
      ZBAR(6)=ZVECT(IZNEAR)
      ZBAR(7)=ZVECT(IZNEAR)
      ZBAR(8)=ZVECT(IZFAR)
      ZBAR(9)=ZVECT(IZFAR)
      ZBAR(10)=ZVECT(IZNEAR)
C
      XBAR(11)=XVECT(IXNEAR)
      XBAR(12)=XVECT(IXNEAR)
      XBAR(13)=XVECT(IXFAR)
      XBAR(14)=XVECT(IXFAR)
      XBAR(15)=XVECT(IXNEAR)
      YBAR(11)=YVECT(IYNEAR)
      YBAR(12)=YVECT(IYFAR)
      YBAR(13)=YVECT(IYFAR)
      YBAR(14)=YVECT(IYNEAR)
      YBAR(15)=YVECT(IYNEAR)
      ZBAR(11)=ZVECT(IZNEAR)
      ZBAR(12)=ZVECT(IZNEAR)
      ZBAR(13)=ZVECT(IZNEAR)
      ZBAR(14)=ZVECT(IZNEAR)
      ZBAR(15)=ZVECT(IZNEAR)
C
      NBAR=15
C
C               *****************
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.NE.'ON'.AND.ISUBG4.NE.'MKBA')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF D3MKBA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGG4,ISUBG4,IERRG4
 9012 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',3A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IDIR
 9013 FORMAT('IDIR = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)WIDTHX,WIDTHY,WIDTHZ
 9014 FORMAT('WIDTHX,WIDTHY,WIDTHZ = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)BASEX,BASEY,BASEZ
 9015 FORMAT('BASEX,BASEY,BASEZ    = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)X3DEYE,Y3DEYE,Z3DEYE
 9016 FORMAT('X3DEYE,Y3DEYE,Z3DEYE    = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)XVECT(1),YVECT(1),ZVECT(1)
 9021 FORMAT('XVECT(1),YVECT(1),ZVECT(1) = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)XVECT(2),YVECT(2),ZVECT(2)
 9022 FORMAT('XVECT(2),YVECT(2),ZVECT(2) = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9023)IXNEAR,IXFAR,IYNEAR,IYFAR,IZNEAR,IZFAR
 9023 FORMAT('IXNEAR,IXFAR,IYNEAR,IYFAR,IZNEAR,IZFAR = ',6I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)NRAW,IRAW
 9031 FORMAT('NRAW,IRAW = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)IRAW,XRAW(IRAW),YRAW(IRAW),ZRAW(IRAW)
 9032 FORMAT('IRAW,XRAW(IRAW),YRAW(IRAW),ZRAW(IRAW) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9041)NBAR
 9041 FORMAT('NBAR = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9042I=1,NBAR
      WRITE(ICOUT,9043)I,XBAR(I),YBAR(I),ZBAR(I)
 9043 FORMAT('I,XBAR(I),YBAR(I),ZBAR(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9042 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE D3MKSP(XRAW,YRAW,ZRAW,NRAW,IRAW,
     1IDIR,
     1BASEX,BASEY,BASEZ,
     1XSPIKE,YSPIKE,ZSPIKE,NSPIKE)
C
C     PURPOSE--GIVEN A SINGLE POINT (XRAW(IRAW),YRAW(IRAW),ZRAW(IRAW))
C              IN 3-SPACE,
C              MAKE (= CONSTRUCT) A 3-D SPIKE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISIONSPIKE
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--88/10
C     ORIGINAL VERSION--SEPTEMBER 1988.
C     UPDATED         --APRIL   1992.  BASE2 TO BASEX/Y/Z
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IDIR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION XRAW(*)
      DIMENSION YRAW(*)
      DIMENSION ZRAW(*)
C
      DIMENSION XSPIKE(*)
      DIMENSION YSPIKE(*)
      DIMENSION ZSPIKE(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCO3D.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='D3MK'
      ISUBN2='SP  '
C
      IF(IBUGG4.NE.'ON'.AND.ISUBG4.NE.'MKSP')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF D3MKSP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGG4,ISUBG4,IERRG4
   52 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',3A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NRAW,IRAW
   53 FORMAT('NRAW,IRAW = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)IDIR
   61 FORMAT('IDIR = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)BASEX,BASEY,BASEZ
   62 FORMAT('BASEX,BASEY,BASEZ = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,63)IRAW,XRAW(IRAW),YRAW(IRAW),ZRAW(IRAW)
   63 FORMAT('IRAW,XRAW(IRAW),YRAW(IRAW),ZRAW(IRAW) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)X3DEYE,Y3DEYE,Z3DEYE
   71 FORMAT('X3DEYE,Y3DEYE,Z3DEYE = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               **************************************************
C               **  STEP 11-                                    **
C               **  MAKE (= CONSTRUCT) A SPIKE.                 **
C               **************************************************
C
      IF(IDIR.EQ.'V')GOTO1110
      IF(IDIR.EQ.'HX')GOTO1120
      IF(IDIR.EQ.'HY')GOTO1130
      GOTO1110
C
 1110 CONTINUE
      XSPIKE(1)=XRAW(IRAW)
      YSPIKE(1)=YRAW(IRAW)
CCCCC THE FOLLOWING LINE WAS FIXED    APRIL 1992 (ALAN)
CCCCC ZSPIKE(1)=BASE2
      ZSPIKE(1)=BASEZ
      GOTO1150
C
 1120 CONTINUE
CCCCC THE FOLLOWING LINE WAS FIXED    APRIL 1992 (ALAN)
CCCCC XSPIKE(1)=BASE2
      XSPIKE(1)=BASEX
      YSPIKE(1)=YRAW(IRAW)
      ZSPIKE(1)=ZRAW(IRAW)
      GOTO1150
C
 1130 CONTINUE
      XSPIKE(1)=XRAW(IRAW)
CCCCC THE FOLLOWING LINE WAS FIXED    APRIL 1992 (ALAN)
CCCCC YSPIKE(1)=BASE2
      YSPIKE(1)=BASEY
      ZSPIKE(1)=ZRAW(IRAW)
      GOTO1150
C
 1150 CONTINUE
C
      XSPIKE(2)=XRAW(IRAW)
      YSPIKE(2)=YRAW(IRAW)
      ZSPIKE(2)=ZRAW(IRAW)
C
      NSPIKE=2
C
C               *****************
C               **  EXIT.      **
C               *****************
C
      IF(IBUGG4.NE.'ON'.AND.ISUBG4.NE.'MKSP')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF D3MKSP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGG4,ISUBG4,IERRG4
 9012 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',3A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IDIR
 9013 FORMAT('IDIR = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)BASEX,BASEY,BASEZ
 9014 FORMAT('BASEX,BASEY,BASEZ = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)NRAW,IRAW
 9021 FORMAT('NRAW,IRAW = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)IRAW,XRAW(IRAW),YRAW(IRAW),ZRAW(IRAW)
 9022 FORMAT('IRAW,XRAW(IRAW),YRAW(IRAW),ZRAW(IRAW) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)X3DEYE,Y3DEYE,Z3DEYE
 9031 FORMAT('X3DEYE,Y3DEYE,Z3DEYE = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9041)NSPIKE
 9041 FORMAT('NSPIKE = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9042I=1,NSPIKE
      WRITE(ICOUT,9043)I,XSPIKE(I),YSPIKE(I),ZSPIKE(I)
 9043 FORMAT('I,XSPIKE(I),YSPIKE(I),ZSPIKE(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9042 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE D3SCAL(PX,PY,NP)
C
C     PURPOSE--EXECUTE A SCALING AND TRANSLATION
C      OF 3D POINTS THAT HAVE ALREADY
C     BEEN TRANSLATED INTO 2D VALUES
C     BUT NOW NEED TO BE SCALED AND TRANSLATED
C     TO PROPER 0 TO 100 SCREEN VALUES.
C     WRITTEN BY--JAMES J. FILLIBEN
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--93/10
C     ORIGINAL VERSION--SEPTEMBER 1993.
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--SEPTEMBER 1993.
C
C-----COMMON STATEMENTS-----------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      INCLUDE 'DPCO3D.INC'
      INCLUDE 'DPCOPC.INC'
      INCLUDE 'DPCOBE.INC'
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
CCCCC CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION PX(*)
      DIMENSION PY(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='D3SC'
      ISUBN2='AL  '
C
      FXMIN=FX1MIN
      FXMAX=FX1MAX
      FYMIN=FY1MIN
      FYMAX=FY1MAX
C
      FXRANG=FXMAX-FXMIN
      FYRANG=FYMAX-FYMIN
      PXRANG=PXMAX-PXMIN
      PYRANG=PYMAX-PYMIN
C
      DO1000I=1,NP
      FXRATI=(PX(I)-FXMIN)/FXRANG
      FYRATI=(PY(I)-FYMIN)/FYRANG
      PX(I)=PXMIN+FXRATI*PXRANG
      PY(I)=PYMIN+FYRATI*PYRANG
 1000 CONTINUE
C
      RETURN
      END
      SUBROUTINE D3TR32(X,Y,Z,N,XT,ZT,NT)
C
C     PURPOSE--EXECUTE A 3-D TRANSFORMATION
C              (ORTHOGRAPHIC OR PERSPECTIVE)
C              WHICH TAKES A 3-D DATA CLOUD
C              AND MAPS IN ONTO A 2-D PLANE
C              (IDENTICALLY THE ORIGINAL XZ PLANE).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, TR32ACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--88/10
C     ORIGINAL VERSION--MARCH     1979.
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--SEPTEMBER 1988.
C     UPDATE          --JUNE      1990.  COMPILE ERROR IN A WRITE STATEMENT
C
C-----COMMON STATEMENTS-----------------------------------------------
C
      INCLUDE 'DPCO3D.INC'
      INCLUDE 'DPCOBE.INC'
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION Z(*)
      DIMENSION XT(*)
      DIMENSION ZT(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='D3TR'
      ISUBN2='32  '
C
      IERRG4='NO'
C
      EPS=0.0000001
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TR32')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF D3TR32--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGG4,ISUBG4,IERRG4
   52 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)I3DPRO
   53 FORMAT('I3DPRO = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)X3DEYE,Y3DEYE,Z3DEYE
   54 FORMAT('X3DEYE,Y3DEYE,Z3DEYE = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)X3DMID,Y3DMID,Z3DMID
   55 FORMAT('X3DMID,Y3DMID,Z3DMID = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,64)D3DCXX,D3DCXY,D3DCXZ
   64 FORMAT('D3DCXX,D3DCXY,D3DCXZ = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,65)D3DCYX,D3DCYY,D3DCYZ
   65 FORMAT('D3DCYX,D3DCYY,D3DCYZ = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,66)D3DCZX,D3DCZY,D3DCZZ
   66 FORMAT('D3DCZX,D3DCZY,D3DCZZ = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)N
   71 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO72I=1,N
      WRITE(ICOUT,73)I,X(I),Y(I),Z(I)
   73 FORMAT('I,X(I),Y(I),Z(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
   72 CONTINUE
   90 CONTINUE
C
C               *********************************************************
C               **  GENERAL DISCUSSION--                               **
C               **  DETERMINE (IN ORIGINAL COORDINATE SYSTEM VALUES)   **
C               **  WHERE THE DATA POINTS FALL ON THE VISUAL PLANE.    **
C               **  FOR EACH (XD,YD,ZD) DATA POINT,                    **
C               **  DETERMINE WHERE THE VISUAL RAY FROM                **
C               **  THE DATA POINT TO OUR EYE                          **
C               **  STRIKES THE VISUAL (PERSPECTIVE) PLANE.            **
C               **  THE VISUAL PLANE IS THAT PLANE                     **
C               **  WHICH IS NORMAL TO OUR EYE                         **
C               **  AND WHICH CONTAINS THE AVERAGE POINT (XM,YM,ZM).   **
C               **  THE EQUATION OF THE VISUAL PLANE IS                **
C               **  (X3DEYE-XM)(X-XM) + (Y3DEYE-YM)(Y-YM) +
C               **                    + (Z3DEYE-YM)(Z-ZM) = 0          **
C               **  WHERE X, Y, Z ARE THE DUMMY VARIABLES              **
C               **  REPRESENTING ANY POINT (X,Y,Z) ON THAT PLANE.      **
C               **  THIS EQUATION MUST BE SOLVED FOR X, Y, AND Z.      **
C               **  THE EQUATIONS OF THE LINE FROM THE DATA POINT
C               **  (XD,YD,ZD)
C               **  TO OUR EYE (X3DEYE,Y3DEYE,Z3DEYE) ARE
C               **  (X-XD)/(X3DEYE-XD) = (Y-YD)/(Y3DEYE-YD)
C               **                     = (Z-ZD)/(Z3DEYE-ZD)
C               **  WHERE (XD,YD,ZD) REPRESENTS A DATA POINT.           **
C               **  THE VISUAL PLANE EQUATION AND THE LINE EQUATIONS    **
C               **  MUST BE COMBINED TO SOLVE FOR THE VALUES (X,Y,Z)    **
C               **  ON THE VISUAL PLANE AS OUR EYE SEES THEM.           **
C               **********************************************************
C
C               **********************************************************
C               **  THE FINAL PLOT STATEMENT WILL INVOLVE
C               **  ONLY 2 VECTORS.
C               **  AT THE MOMENT, THE POINTS (XP,YP,ZP)
C               **  ON THE VISUAL PLANE ARE DEFINED
C               **  BY 3 COORDINATE VALUES.
C               **  TO REDUCE THE 3 COORDINATE VALUES
C               **  TO 2 COORDINATE VALUES,
C               **  WE MUST ROTATE THE VISUAL PLANE
C               **  SO THAT IT IS PARALLEL TO THE ORIGINAL XZ PLANE.
C               **  TO CARRY OUT SUCH A ROTATION, WE MUST
C               **  DETERMINE THE DIRECTION NUMBERS AND DIRECTION COSINES
C               **  OF THE NEW AXES IN TERMS OF THE OLD COORDINATE SYSTEM.
C               **  THE NEW Y AXIS WILL (BY CONSTRUCTION) BE
C               **  ON THE NORMAL LINE TRAVELING FROM
C               **  THE AVERAGE POINT (XM,YM,ZM) TO OUR EYE POINT
C               **  (X3DEYE,Y3DEYE,Z3DEYE)
C               **  AND WILL THEREFORE HAVE DIRECTIONS NUMBERS
C               **  X3DEYE, Y3DEYE, Z3DEYE
C               **  THE NEW Z AXIS WILL BE PERPENDICULAR TO THE NEW Y AXIS
C               **  AND WILL RESIDE IN THE PLANE CONTAINING THE
C               **  THE FOLLOWING 3 POINTS--
C               **      1) THE AVERAGE POINT (XM,YM,ZM)
C               **      2) THE EYE POINT (X3DEYE,Y3DEYE,Z3DEYE)
C               **      3) SOME POINT (SAY (XM,YM,ZM+1)) OF THE OLD Z AXIS
C               **         DISPLACED OVER SO AS TO EMANATE FROM (XM,YM,ZM).
C               **  THE ABOVE 3 POINTS DEFINE A VERTICAL PLANE.
C               **  THE PURPOSE OF THE VERTICAL PLANE IS TO DEFINE
C               **  WHICH DIRECTION IS 'UP' IN THE FINAL PICTURE.
C               **  THE EQUATION OF THE VERTICAL PLANE IS
C               **  (A-XM)(X-XM) + (B-YM)(Y-YM) + (C-ZM)(Z-ZM) = 0 .
C               **  THIS EQUATION MUST BE SOLVED FOR A, B, AND C.
C               **  WITHOUT LOSS OF GENERALITY, A MAY BE INITIALLY SET TO 1.
C               **  THE SOLUTION TURNS OUT TO BE
C               **      A = 1
C               **      B = -X3DEYE/Y3DEYE
C               **      C = 0
C               **  NOTE, HOWEVER, THAT THESE A, B, AND C VALUES
C               **  FOR THIS VERTICAL PLANE WILL BE IDENTICAL TO THE
C               **  DIRECTION NUMBERS FOR THE NORMAL TO THIS VERTICAL PLANE
C               **  WHICH IS IDENTICALLY THE NEW X AXIS
C               **  AND SO THE ABOVE A, B, AND C VALUES DEFINE THE DIRECTION
C               **  DIRECTION NUMBERS FOR THE NEW X AXIS.
C               **  TO SOLVE FOR THE DIRECTION NUMBERS FOR THE NEW Z AXIS,
C               **  WE SEEK 3 DIRECTION NUMBERS D, E, AND F
C               **  WHICH MUST BE PERPENDICULAR TO BOTH THE
C               **  NEW Y AXIS (WITH DIRECTION NUMBERS X3DEYE, Y3DEYE,
C               **  AND Z3DEYE)
C               **  AND THE NEW X AXIS (WITH DIRECTION NUMBERS A, B, AND C ABOVE
C               **  WITHOUT LOSS OF GENERALITY, D MAY BE INITIALLY SET TO 1.
C               **  NOTE THAT WHENEVER 2 LINES ARE PERPENDICULAR,
C               **  THE INNER PRODUCT OF THE DIRECTION NUMBERS MUST = 0.
C               **  WITHOUT LOSS OF GENERALITY, D MAY BE INITIALLY SET TO 1.
C               **  INCORPORATING THE 2 INNER PRODUCT EQUATIONS,
C               **  WE MAY SOLVE FOR E AND F.
C               **  THE SOLUTIONS TURN OUT TO BE
C               **      D = 1
C               **      E = Y3DEYE/X3DEYE
C               **      F = (-X3DEYE*X3DEYE - Y3DEYE*Y3DEYE) / (X3DEYE*Z3DEYE)
C               **
C               **  IN SUMMARY, THE DIRECTION NUMBERS FOR THE 3 NEW AXES
C               **  MAY BE WRITTEN AS
C               **      NEW X AXIS:  Y3DEYE       -X3DEYE     0
C               **      NEW Y AXIS:  X3DEYE       Y3DEYE      Z3DEYE
C               **      NEW Z AXIS:  -X3DEYE*Z3DEYE   -Y3DEYE*Z3DEYE
C               **                                        X3DEYE*X3DEYE+Y3DEYE
C               **  NOTE THAT BY INSPECTION WE SEE RETROSPECTIVELY
C               **  THAT THE 3 INNER PRODUCTS ALL = 0
C               **  AND SO THE 3 DEFINED AXES ARE ALL PERPENDICULAR
C               **  (AS THEY SHOULD BE).
C               **
C               **  THE CORRESPONDING DIRECTION COSINES
C               **  ARE GOTTEN BY NORMALIZATION TO UNITY;
C               **  LET US SYMBOLICALLY REPRESENT THEM BY--
C               **      D3DCXX   D3DCXY   D3DCXZ
C               **      D3DCYX   D3DCYY   D3DCYZ
C               **      D3DCZX   D3DCZY   D3DCZZ
C               **  THE ABOVE RESULTS WERE ACTUALLY ARRIVED AT
C               **  (AND ARE VALID FOR) BY DISPLACING THE OLD ORIGIN
C               **  FROM (0,0,0) TO (XM,YM,ZM).
C               **  THIS SIMPLIFIES THE EQUATIONS CONSIDERABLY.
C               **
C               **  GIVEN THAT WE NOW HAVE THE DIRECTION COSINES
C               **  OF THE NEW AXES IN TERMS OF THE OLD COORDINATES,
C               **  WE MAKE USE OF
C               **  EISENHART (COORDINATE GEOMETRY, PAGE 160) WHICH STATES
C               **  THAT THE LINEAR TRANSFORMATION THAT IS NEEDED TO CARRY OUT
C               **  THE ROTATION FROM THE VISUAL PLANE TO THE XZ PLANE
C               **  IS GIVEN BY
C               **      XT = XM + D3DCXX(X-XM) + D3DCXY(Y-YM) + D3DCXZ(Z-ZM)
C               **      YT = YM + D3DCYX(X-XM) + D3DCYY(Y-YM) + D3DCYZ(Z-ZM)
C               **      ZT = ZM + D3DCZX(X-XM) + D3DCZY(Y-YM) + D3DCZZ(Z-ZM)
C               **
C               **  NOTE THAT BY INSPECTION OF THE ABOVE TRANSFORMATION
C               **  IT IS SEEN THAT (XM,YM,ZM) IS MAPPED INTO (XM,YM,ZM)
C               **  (AS IT SHOULD BE).
C               **  NOTE ALSO THAT THE EYE POINT AND ANY POINT ALONG THE LINE
C               **  OF SIGHT WOULD HAVE BEEN MAPPED INTO (XM,YM,ZM)
C               **  AS IT SHOULD BE.
C               **  NOTE ALSO THAT ALL POINTS ON THE VISUAL PLANE
C               **  SINCE THEY SATISFY
C               **     (X3DEYE-XM)(X-XM) + (Y3DEYE-YM)(Y-YM) + (Z3DEYE-ZM)(Z-ZM)
C               **     = 0
C               **  GETS MAPPED INTO THE CONSTANT YT VALUE OF YT = YM
C               **  AND SO THE TRANSFORMED PLOT SURFACE IS ONE WHICH
C               **  IS PARALLEL TO THE XZ PLANE BUT IS DISPLACED
C               **  YM UNITS OUT FROM THE XZ PLANE.
C               **  THIS PLOT PLANE WILL CONTAIN THE POINT (XM,YM,ZM).
C               ****************************************************************
C
C               **************************************************
C               **  STEP 11--                                   **
C               **  BRANCH TO THE APPROPRIATE                   **
C               **  TRANSFORMATION                              **
C               **************************************************
C
      ISTEPN='11'
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'TR32')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NT=N
C
      XDEL=X3DEYE-X3DMID
      IF(XDEL.EQ.0.0)XDEL=EPS
      YDEL=Y3DEYE-Y3DMID
      IF(YDEL.EQ.0.0)YDEL=EPS
      ZDEL=Z3DEYE-Z3DMID
      IF(ZDEL.EQ.0.0)ZDEL=EPS
C
      IF(I3DPRO.EQ.'ORTH')GOTO2100
      GOTO3100
C
C               **************************************************
C               **  STEP 21--                                   **
C               **  TREAT THE ORTHOGRAPHIC TRANSFORMATION CASE  **
C               **************************************************
C
 2100 CONTINUE
C
      ISTEPN='21'
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'TR32')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C     THE FOLLOWING IS INCORRECT (XM FOR X(I) ETC.)
CCCCC MAY 1996.  NP12 IS UNDEFINED.  USE NT.
CCCCC DO2110I=1,NP12
      DO2110I=1,NT
C
C     ***** 5 LINES OF CODE TO ADJUST FOR DIVISION BY 0 ADDED AUGUST 1983 *****
CCCCC A11=XDEL
CCCCC A12=YDEL
CCCCC A13=ZDEL
CCCCC A23=Y3DEYE-Y3DMID
CCCCC IF(A23.EQ.0.0)A21=EPS
CCCCC A23=-(X3DEYE-X3DMID)
CCCCC IF(A23.EQ.0.0)A22=EPS
CCCCC A23=0.0
CCCCC A31=0.0
CCCCC A32=Z3DEYE-Z3DMID
CCCCC IF(A32.EQ.0.0)A32=EPS
CCCCC A33=-(Y3DEYE-Y3DMID)
CCCCC IF(A33.EQ.0.0)A33=EPS
C
CCCCC R1=XDEL*X3DMID+YDEL*Y3DMID+ZDEL*Z3DMID
CCCCC R2=(Y3DEYE-Y3DMID)*X3DMID-(X3DEYE-X3DMID)*YM
CCCCC R3=(Z3DEYE-Z3DMID)*Y3DMID-(Y3DEYE-Y3DMID)*Z3DMID
C
CCCCC P12=-A23/A11
CCCCC P13=-A32/(P12*A12+A23)
C
CCCCC ZPI=(P13*(P12*R1+R2)+R3)/
CCCCC1(P13*P12*A13+A33)
CCCCC YPI=(R3-A33*ZPI)/A32
CCCCC XPI=(R2-A23*YPI)/A21
CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'TR32')
CCCCC1WRITE(ICOUT,2111)I,XPI,YPI,ZPI
C2111 FORMAT('I,XPI,YPI,ZPI = ',I8,3E15.7)
CCCCC IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'TR32')
CCCCC1CALL DPWRST('XXX','BUG ')
C
CCCCC DELX=XPI-X3DMID
CCCCC DELY=YPI-Y3DMID
CCCCC DELZ=ZPI-Z3DMID
CCCCC XT(I)=X3DMID+D3DCXX*DELX+D3DCXY*DELY+D3DCXZ*DELZ
CCCCC YT(I)=Y3DMID+D3DCYX*DELX+D3DCYY*DELY+D3DCYZ*DELZ
CCCCC ZT(I)=X3DMID+D3DCZX*DELX+D3DCZY*DELY+D3DCZZ*DELZ
      DELX=X(I)-X3DMID
      DELY=Y(I)-Y3DMID
      DELZ=Z(I)-Z3DMID
      XT(I)=X3DMID+TERMXX*DELX+TERMXY*DELY+TERMXZ*DELZ
      ZT(I)=X3DMID+TERMZX*DELX+TERMZY*DELY+TERMZZ*DELZ
C
 2110 CONTINUE
      GOTO9000
C
C               **************************************************
C               **  STEP 31--                                   **
C               **  TREAT THE PERSPECTIVE TRANSFORMATION CASE   **
C               **************************************************
C
 3100 CONTINUE
C
      ISTEPN='31'
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'TR32')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO3110I=1,N
C
C     ***** 5 LINES OF CODE TO ADJUST FOR DIVISION BY 0 ADDED AUGUST 1983 *****
      A11=XDEL
      A12=YDEL
      A13=ZDEL
      A21=Y3DEYE-Y(I)
      IF(A21.EQ.0.0)A21=EPS
      A22=-(X3DEYE-X(I))
      IF(A22.EQ.0.0)A22=EPS
      A23=0.0
      A31=0.0
      A32=Z3DEYE-Z(I)
      IF(A32.EQ.0.0)A32=EPS
      A33=-(Y3DEYE-Y(I))
      IF(A33.EQ.0.0)A33=EPS
C
      R1=XDEL*X3DMID+YDEL*Y3DMID+ZDEL*Z3DMID
      R2=(Y3DEYE-Y(I))*X(I)-(X3DEYE-X(I))*Y(I)
      R3=(Z3DEYE-Z(I))*Y(I)-(Y3DEYE-Y(I))*Z(I)
C
      P12=-A21/A11
      P13=-A32/(P12*A12+A22)
C
      ZPI=(P13*(P12*R1+R2)+R3)/
     1(P13*P12*A13+A33)
      YPI=(R3-A33*ZPI)/A32
      XPI=(R2-A22*YPI)/A21
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'TR32')
     1WRITE(ICOUT,3111)I,XPI,YPI,ZPI
 3111 FORMAT('I,XPI,YPI,ZPI = ',I8,3E15.7)
      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'TR32')
     1CALL DPWRST('XXX','BUG ')
C
      DELX=XPI-X3DMID
      DELY=YPI-Y3DMID
      DELZ=ZPI-Z3DMID
      XT(I)=X3DMID+D3DCXX*DELX+D3DCXY*DELY+D3DCXZ*DELZ
CCCCC YT(I)=Y3DMID+D3DCYX*DELX+D3DCYY*DELY+D3DCYZ*DELZ
      ZT(I)=X3DMID+D3DCZX*DELX+D3DCZY*DELY+D3DCZZ*DELZ
C
 3110 CONTINUE
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TR32')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF D3TR32--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGG4,ISUBG4,IERRG4
 9012 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',3A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)I3DPRO
 9013 FORMAT('I3DPRO = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)IBUGG4,ISUBG4,IERRG4
 9014 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',3A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)X3DEYE,Y3DEYE,Z3DEYE
 9015 FORMAT('X3DEYE,Y3DEYE,Z3DEYE = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)X3DMID,Y3DMID,Z3DMID
 9016 FORMAT('X3DMID,Y3DMID,Z3DMID = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9024)D3DCXX,D3DCXY,D3DCXZ
 9024 FORMAT('D3DCXX,D3DCXY,D3DCXZ = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9025)D3DCYX,D3DCYY,D3DCYZ
 9025 FORMAT('D3DCYX,D3DCYY,D3DCYZ = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9026)D3DCZX,D3DCZY,D3DCZZ
 9026 FORMAT('D3DCZX,D3DCZY,D3DCZZ = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)XDEL,YDEL,ZDEL
 9031 FORMAT('XDEL,YDEL,ZDEL = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)A11,A12,A13
 9032 FORMAT('A11,A12,A13    = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9033)A21,A22,A23
 9033 FORMAT('A21,A22,A23    = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9034)A31,A32,A33
 9034 FORMAT('A31,A32,A33    = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9035)R1,R2,R3
 9035 FORMAT('R1,R2,R3       = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9036)P12,P13
 9036 FORMAT('P12,P13        = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9037)XPI,YPI,ZPI
 9037 FORMAT('XPI,YPI,ZPI    = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9038)DELX,DELY,DELZ
 9038 FORMAT('DELX,DELY,DELZ = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9039)XT(N),ZT(N)
 9039 FORMAT('XT(N),ZT(N)    = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9041)N,NT
 9041 FORMAT('N,NT = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9042I=1,N
      WRITE(ICOUT,9043)I,X(I),Y(I),Z(I),XT(I),ZT(I)
 9043 FORMAT('I,X(I),Y(I),Z(I),XT(I),ZT(I) = ',I8,5E11.3)
      CALL DPWRST('XXX','BUG ')
 9042 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE D3TRXP(X,Y,N,IDIR,ABASE,
     1FXMIN,FXMAX,FXRANG,FYMIN,FYMAX,FYRANG,
     1PXMIN,PXMAX,PXRANG,PYMIN,PYMAX,PYRANG,
     1PX,PY,NP,PBASE)
C
C     PURPOSE--TRANSLATE 2-D RAW OR INTERMEDIATE DATA
C              INTO 2-D VISUAL PLANE (0 TO 100) DATA
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--88/10
C     ORIGINAL VERSION--SEPTEMBER 1988.
C
C-----COMMON STATEMENTS-----------------------------------------------
C
      INCLUDE 'DPCO3D.INC'
      INCLUDE 'DPCOBE.INC'
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IDIR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
CCCCC CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION PX(*)
      DIMENSION PY(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='D3TR'
      ISUBN2='XP  '
C
      IERRG4='NO'
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TRXP')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF D3TRXP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGG4,ISUBG4,IERRG4
   52 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)FXMIN,FXMAX,FXRANG
   53 FORMAT('FXMIN,FXMAX,FXRANG = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)FYMIN,FYMAX,FYRANG
   54 FORMAT('FYMIN,FYMAX,FYRANG = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)PXMIN,PXMAX,PXRANG
   55 FORMAT('PXMIN,PXMAX,PXRANG = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,56)PYMIN,PYMAX,PYRANG
   56 FORMAT('PYMIN,PYMAX,PYRANG = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,57)ABASE
   57 FORMAT('ABASE = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)N,IDIR
   61 FORMAT('N,IDIR = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      DO62I=1,N
      WRITE(ICOUT,63)I,X(I),Y(I)
   63 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   62 CONTINUE
   90 CONTINUE
C
C               *****************************************************
C               **  STEP 11--                                      **
C               **  TRANSLATE THE 2-D PLANE DATA POINTS            **
C               **  INTO STANDARDIZED (0.0 TO 100.0) COORDINATES.  **
C               *****************************************************
C
      NP=N
C
      DO1110I=1,N
      FXRATI=(X(I)-FXMIN)/FXRANG
      FYRATI=(Y(I)-FYMIN)/FYRANG
      PX(I)=PXMIN+FXRATI*PXRANG
      PY(I)=PYMIN+FYRATI*PYRANG
 1110 CONTINUE
C
      IF(IDIR.EQ.'V')GOTO1120
      GOTO1129
 1120 CONTINUE
      FYRATI=(ABASE-FYMIN)/FYRANG
      PBASE=PYMIN+FYRATI*PYRANG
 1129 CONTINUE
C
      IF(IDIR.EQ.'H')GOTO1130
      GOTO1139
 1130 CONTINUE
      FXRATI=(ABASE-FXMIN)/FXRANG
      PBASE=PXMIN+FXRATI*PXRANG
 1139 CONTINUE
C
C               **************************************************
C               **  STEP 90--                                   **
C               **  EXIT.                                       **
C               **************************************************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TRXP')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF D3TRXP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGG4,ISUBG4,IERRG4
 9012 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)FXMIN,FXMAX,FXRANG
 9013 FORMAT('FXMIN,FXMAX,FXRANG = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)FYMIN,FYMAX,FYRANG
 9014 FORMAT('FYMIN,FYMAX,FYRANG = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)PXMIN,PXMAX,PXRANG
 9015 FORMAT('PXMIN,PXMAX,PXRANG = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)PYMIN,PYMAX,PYRANG
 9016 FORMAT('PYMIN,PYMAX,PYRANG = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)ABASE
 9017 FORMAT('ABASE = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)N,NP,IDIR
 9021 FORMAT('N,NP,IDIR = ',2I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      DO9022I=1,N
      WRITE(ICOUT,9023)I,X(I),Y(I),PX(I),PY(I)
 9023 FORMAT('I,X(I),Y(I),PX(I),PY(I) = ',I8,4E15.7)
      CALL DPWRST('XXX','BUG ')
 9022 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      FUNCTION E1 (X)
C***BEGIN PROLOGUE  E1
C***PURPOSE  Compute the exponential integral E1(X).
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C5
C***TYPE      SINGLE PRECISION (E1-S, DE1-D)
C***KEYWORDS  E1 FUNCTION, EXPONENTIAL INTEGRAL, FNLIB,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C E1 calculates the single precision exponential integral, E1(X), for
C positive single precision argument X and the Cauchy principal value
C for negative X.  If principal values are used everywhere, then, for
C all X,
C
C    E1(X) = -Ei(-X)
C or
C    Ei(X) = -E1(-X).
C
C
C Series for AE11       on the interval -1.00000D-01 to  0.
C                                        with weighted error   1.76E-17
C                                         log weighted error  16.75
C                               significant figures required  15.70
C                                    decimal places required  17.55
C
C
C Series for AE12       on the interval -2.50000D-01 to -1.00000D-01
C                                        with weighted error   5.83E-17
C                                         log weighted error  16.23
C                               significant figures required  15.76
C                                    decimal places required  16.93
C
C
C Series for E11        on the interval -4.00000D+00 to -1.00000D+00
C                                        with weighted error   1.08E-18
C                                         log weighted error  17.97
C                               significant figures required  19.02
C                                    decimal places required  18.61
C
C
C Series for E12        on the interval -1.00000D+00 to  1.00000D+00
C                                        with weighted error   3.15E-18
C                                         log weighted error  17.50
C                        approx significant figures required  15.8
C                                    decimal places required  18.10
C
C
C Series for AE13       on the interval  2.50000D-01 to  1.00000D+00
C                                        with weighted error   2.34E-17
C                                         log weighted error  16.63
C                               significant figures required  16.14
C                                    decimal places required  17.33
C
C
C Series for AE14       on the interval  0.          to  2.50000D-01
C                                        with weighted error   5.41E-17
C                                         log weighted error  16.27
C                               significant figures required  15.38
C                                    decimal places required  16.97
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891115  Modified prologue description.  (WRB)
C   891115  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920618  Removed space from variable names.  (RWC, WRB)
C***END PROLOGUE  E1
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DIMENSION AE11CS(39), AE12CS(25), E11CS(19), E12CS(16),
     1  AE13CS(25), AE14CS(26)
      LOGICAL FIRST
      SAVE AE11CS, AE12CS, E11CS, E12CS, AE13CS, AE14CS,
     1 NTAE11, NTAE12, NTE11, NTE12, NTAE13, NTAE14, XMAX, FIRST
      DATA AE11CS( 1) /    .1215032397 1606579E0 /
      DATA AE11CS( 2) /   -.0650887785 13550150E0 /
      DATA AE11CS( 3) /    .0048976513 57459670E0 /
      DATA AE11CS( 4) /   -.0006492378 43027216E0 /
      DATA AE11CS( 5) /    .0000938404 34587471E0 /
      DATA AE11CS( 6) /    .0000004202 36380882E0 /
      DATA AE11CS( 7) /   -.0000081133 74735904E0 /
      DATA AE11CS( 8) /    .0000028042 47688663E0 /
      DATA AE11CS( 9) /    .0000000564 87164441E0 /
      DATA AE11CS(10) /   -.0000003448 09174450E0 /
      DATA AE11CS(11) /    .0000000582 09273578E0 /
      DATA AE11CS(12) /    .0000000387 11426349E0 /
      DATA AE11CS(13) /   -.0000000124 53235014E0 /
      DATA AE11CS(14) /   -.0000000051 18504888E0 /
      DATA AE11CS(15) /    .0000000021 48771527E0 /
      DATA AE11CS(16) /    .0000000008 68459898E0 /
      DATA AE11CS(17) /   -.0000000003 43650105E0 /
      DATA AE11CS(18) /   -.0000000001 79796603E0 /
      DATA AE11CS(19) /    .0000000000 47442060E0 /
      DATA AE11CS(20) /    .0000000000 40423282E0 /
      DATA AE11CS(21) /   -.0000000000 03543928E0 /
      DATA AE11CS(22) /   -.0000000000 08853444E0 /
      DATA AE11CS(23) /   -.0000000000 00960151E0 /
      DATA AE11CS(24) /    .0000000000 01692921E0 /
      DATA AE11CS(25) /    .0000000000 00607990E0 /
      DATA AE11CS(26) /   -.0000000000 00224338E0 /
      DATA AE11CS(27) /   -.0000000000 00200327E0 /
      DATA AE11CS(28) /   -.0000000000 00006246E0 /
      DATA AE11CS(29) /    .0000000000 00045571E0 /
      DATA AE11CS(30) /    .0000000000 00016383E0 /
      DATA AE11CS(31) /   -.0000000000 00005561E0 /
      DATA AE11CS(32) /   -.0000000000 00006074E0 /
      DATA AE11CS(33) /   -.0000000000 00000862E0 /
      DATA AE11CS(34) /    .0000000000 00001223E0 /
      DATA AE11CS(35) /    .0000000000 00000716E0 /
      DATA AE11CS(36) /   -.0000000000 00000024E0 /
      DATA AE11CS(37) /   -.0000000000 00000201E0 /
      DATA AE11CS(38) /   -.0000000000 00000082E0 /
      DATA AE11CS(39) /    .0000000000 00000017E0 /
      DATA AE12CS( 1) /    .5824174951 3472674E0 /
      DATA AE12CS( 2) /   -.1583488509 0578275E0 /
      DATA AE12CS( 3) /   -.0067642755 90323141E0 /
      DATA AE12CS( 4) /    .0051258439 50185725E0 /
      DATA AE12CS( 5) /    .0004352324 92169391E0 /
      DATA AE12CS( 6) /   -.0001436133 66305483E0 /
      DATA AE12CS( 7) /   -.0000418013 20556301E0 /
      DATA AE12CS( 8) /   -.0000027133 95758640E0 /
      DATA AE12CS( 9) /    .0000011513 81913647E0 /
      DATA AE12CS(10) /    .0000004206 50022012E0 /
      DATA AE12CS(11) /    .0000000665 81901391E0 /
      DATA AE12CS(12) /    .0000000006 62143777E0 /
      DATA AE12CS(13) /   -.0000000028 44104870E0 /
      DATA AE12CS(14) /   -.0000000009 40724197E0 /
      DATA AE12CS(15) /   -.0000000001 77476602E0 /
      DATA AE12CS(16) /   -.0000000000 15830222E0 /
      DATA AE12CS(17) /    .0000000000 02905732E0 /
      DATA AE12CS(18) /    .0000000000 01769356E0 /
      DATA AE12CS(19) /    .0000000000 00492735E0 /
      DATA AE12CS(20) /    .0000000000 00093709E0 /
      DATA AE12CS(21) /    .0000000000 00010707E0 /
      DATA AE12CS(22) /   -.0000000000 00000537E0 /
      DATA AE12CS(23) /   -.0000000000 00000716E0 /
      DATA AE12CS(24) /   -.0000000000 00000244E0 /
      DATA AE12CS(25) /   -.0000000000 00000058E0 /
      DATA E11CS( 1) / -16.1134616555 71494026E0 /
      DATA E11CS( 2) /   7.7940727787 426802769E0 /
      DATA E11CS( 3) /  -1.9554058188 631419507E0 /
      DATA E11CS( 4) /    .3733729386 6277945612E0 /
      DATA E11CS( 5) /   -.0569250319 1092901938E0 /
      DATA E11CS( 6) /    .0072110777 6966009185E0 /
      DATA E11CS( 7) /   -.0007810490 1449841593E0 /
      DATA E11CS( 8) /    .0000738809 3356262168E0 /
      DATA E11CS( 9) /   -.0000062028 6187580820E0 /
      DATA E11CS(10) /    .0000004681 6002303176E0 /
      DATA E11CS(11) /   -.0000000320 9288853329E0 /
      DATA E11CS(12) /    .0000000020 1519974874E0 /
      DATA E11CS(13) /   -.0000000001 1673686816E0 /
      DATA E11CS(14) /    .0000000000 0627627066E0 /
      DATA E11CS(15) /   -.0000000000 0031481541E0 /
      DATA E11CS(16) /    .0000000000 0001479904E0 /
      DATA E11CS(17) /   -.0000000000 0000065457E0 /
      DATA E11CS(18) /    .0000000000 0000002733E0 /
      DATA E11CS(19) /   -.0000000000 0000000108E0 /
      DATA E12CS( 1) /  -0.0373902147 92202795E0 /
      DATA E12CS( 2) /   0.0427239860 62209577E0 /
      DATA E12CS( 3) /   -.1303182079 849700544E0 /
      DATA E12CS( 4) /    .0144191240 2469889073E0 /
      DATA E12CS( 5) /   -.0013461707 8051068022E0 /
      DATA E12CS( 6) /    .0001073102 9253063780E0 /
      DATA E12CS( 7) /   -.0000074299 9951611943E0 /
      DATA E12CS( 8) /    .0000004537 7325690753E0 /
      DATA E12CS( 9) /   -.0000000247 6417211390E0 /
      DATA E12CS(10) /    .0000000012 2076581374E0 /
      DATA E12CS(11) /   -.0000000000 5485141480E0 /
      DATA E12CS(12) /    .0000000000 0226362142E0 /
      DATA E12CS(13) /   -.0000000000 0008635897E0 /
      DATA E12CS(14) /    .0000000000 0000306291E0 /
      DATA E12CS(15) /   -.0000000000 0000010148E0 /
      DATA E12CS(16) /    .0000000000 0000000315E0 /
      DATA AE13CS( 1) /   -.6057732466 4060346E0 /
      DATA AE13CS( 2) /   -.1125352434 8366090E0 /
      DATA AE13CS( 3) /    .0134322662 47902779E0 /
      DATA AE13CS( 4) /   -.0019268451 87381145E0 /
      DATA AE13CS( 5) /    .0003091183 37720603E0 /
      DATA AE13CS( 6) /   -.0000535641 32129618E0 /
      DATA AE13CS( 7) /    .0000098278 12880247E0 /
      DATA AE13CS( 8) /   -.0000018853 68984916E0 /
      DATA AE13CS( 9) /    .0000003749 43193568E0 /
      DATA AE13CS(10) /   -.0000000768 23455870E0 /
      DATA AE13CS(11) /    .0000000161 43270567E0 /
      DATA AE13CS(12) /   -.0000000034 66802211E0 /
      DATA AE13CS(13) /    .0000000007 58754209E0 /
      DATA AE13CS(14) /   -.0000000001 68864333E0 /
      DATA AE13CS(15) /    .0000000000 38145706E0 /
      DATA AE13CS(16) /   -.0000000000 08733026E0 /
      DATA AE13CS(17) /    .0000000000 02023672E0 /
      DATA AE13CS(18) /   -.0000000000 00474132E0 /
      DATA AE13CS(19) /    .0000000000 00112211E0 /
      DATA AE13CS(20) /   -.0000000000 00026804E0 /
      DATA AE13CS(21) /    .0000000000 00006457E0 /
      DATA AE13CS(22) /   -.0000000000 00001568E0 /
      DATA AE13CS(23) /    .0000000000 00000383E0 /
      DATA AE13CS(24) /   -.0000000000 00000094E0 /
      DATA AE13CS(25) /    .0000000000 00000023E0 /
      DATA AE14CS( 1) /   -.1892918000 753017E0 /
      DATA AE14CS( 2) /   -.0864811785 5259871E0 /
      DATA AE14CS( 3) /    .0072241015 4374659E0 /
      DATA AE14CS( 4) /   -.0008097559 4575573E0 /
      DATA AE14CS( 5) /    .0001099913 4432661E0 /
      DATA AE14CS( 6) /   -.0000171733 2998937E0 /
      DATA AE14CS( 7) /    .0000029856 2751447E0 /
      DATA AE14CS( 8) /   -.0000005659 6491457E0 /
      DATA AE14CS( 9) /    .0000001152 6808397E0 /
      DATA AE14CS(10) /   -.0000000249 5030440E0 /
      DATA AE14CS(11) /    .0000000056 9232420E0 /
      DATA AE14CS(12) /   -.0000000013 5995766E0 /
      DATA AE14CS(13) /    .0000000003 3846628E0 /
      DATA AE14CS(14) /   -.0000000000 8737853E0 /
      DATA AE14CS(15) /    .0000000000 2331588E0 /
      DATA AE14CS(16) /   -.0000000000 0641148E0 /
      DATA AE14CS(17) /    .0000000000 0181224E0 /
      DATA AE14CS(18) /   -.0000000000 0052538E0 /
      DATA AE14CS(19) /    .0000000000 0015592E0 /
      DATA AE14CS(20) /   -.0000000000 0004729E0 /
      DATA AE14CS(21) /    .0000000000 0001463E0 /
      DATA AE14CS(22) /   -.0000000000 0000461E0 /
      DATA AE14CS(23) /    .0000000000 0000148E0 /
      DATA AE14CS(24) /   -.0000000000 0000048E0 /
      DATA AE14CS(25) /    .0000000000 0000016E0 /
      DATA AE14CS(26) /   -.0000000000 0000005E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  E1
      IF (FIRST) THEN
         ETA = 0.1*R1MACH(3)
         NTAE11 = INITS (AE11CS, 39, ETA)
         NTAE12 = INITS (AE12CS, 25, ETA)
         NTE11 = INITS (E11CS, 19, ETA)
         NTE12 = INITS (E12CS, 16, ETA)
         NTAE13 = INITS (AE13CS, 25, ETA)
         NTAE14 = INITS (AE14CS, 26, ETA)
C
         XMAXT = -LOG (R1MACH(1))
         XMAX = XMAXT - LOG(XMAXT)
      ENDIF
      FIRST = .FALSE.
C
      IF (X.GT.(-10.)) GO TO 20
C
C E1(X) = -EI(-X) FOR X .LE. -10.
C
      E1 = EXP(-X)/X * (1.+CSEVL (20./X+1., AE11CS, NTAE11))
      RETURN
C
 20   IF (X.GT.(-4.0)) GO TO 30
C
C E1(X) = -EI(-X) FOR -10. .LT. X .LE. -4.
C
      E1 = EXP(-X)/X * (1.+CSEVL ((40./X+7.)/3., AE12CS, NTAE12))
      RETURN
C
 30   IF (X.GT.(-1.0)) GO TO 40
C
C E1(X) = -EI(-X) FOR -4. .LT. X .LE. -1.
C
      E1 = -LOG(ABS(X)) + CSEVL ((2.*X+5.)/3., E11CS, NTE11)
      RETURN
C
 40   IF (X.GT.1.) GO TO 50
      IF (X .EQ. 0.) THEN
        WRITE(ICOUT,41)
   41   FORMAT('***** ERORR FROM E1, X IS ZER0.  *******')
        CALL DPWRST('XXX','BUG ')
        E1=0.0
        RETURN
      ENDIF
C
C E1(X) = -EI(-X) FOR -1. .LT. X .LE. 1.,  X .NE. 0.
C
      E1 = (-LOG(ABS(X)) - 0.6875 + X) + CSEVL (X, E12CS, NTE12)
      RETURN
C
 50   IF (X.GT.4.) GO TO 60
C
C E1(X) = -EI(-X) FOR 1. .LT. X .LE. 4.
C
      E1 = EXP(-X)/X * (1.+CSEVL ((8./X-5.)/3., AE13CS, NTAE13))
      RETURN
C
 60   IF (X.GT.XMAX) GO TO 70
C
C E1(X) = -EI(-X) FOR 4. .LT. X .LE. XMAX
C
      E1 = EXP(-X)/X * (1. + CSEVL (8./X-1., AE14CS, NTAE14))
      RETURN
C
C E1(X) = -EI(-X) FOR X .GT. XMAX
C
 70   CONTINUE
      WRITE(ICOUT,71)
      CALL DPWRST('XXX','BUG ')
   71 FORMAT('***** WARNING FROM E1, UNDERFLOW BECAUSE THE ',
     1       'VALUE OF X IS SO LARGE.  ****')
      E1 = 0.
      RETURN
C
      END
      SUBROUTINE EA(NEWFLG,SVALUE,LIMEXP,RESULT,ABSERR,EPSTAB,IERR)
C   PART OF QAGI CODE.
C***BEGIN PROLOGUE  EA
C***DATE WRITTEN   800101  (YYMMDD)
C***REVISION DATE  871208   (YYMMDD)
C***CATEGORY NO.  E5
C***KEYWORDS  CONVERGENCE ACCELERATION,EPSILON ALGORITHM,EXTRAPOLATION
C***AUTHOR  PIESSENS, ROBERT, APPLIED MATH. AND PROGR. DIV. -
C             K. U. LEUVEN
C           DE DONCKER-KAPENGA, ELISE,WESTERN MICHIGAN UNIVERSITY
C           KAHANER, DAVID K., NATIONAL BUREAU OF STANDARDS
C           STARKENBURG, C. B., NATIONAL BUREAU OF STANDARDS
C***PURPOSE  Given a slowly convergent sequence, this routine attempts
C            to extrapolate nonlinearly to a better estimate of the
C            sequence's limiting value, thus improving the rate of
C            convergence. Routine is based on the epsilon algorithm
C            of P. Wynn. An estimate of the absolute error is also
C            given.
C     THIS PROLOGUE HAS BEEN REMOVED FOR REASONS OF SPACE
C     FOR A COMPLETE COPY OF THIS ROUTINE CONTACT THE AUTHORS
C     From the book "Numerical Methods and Software"
C          by  D. Kahaner, C. Moler, S. Nash
C               Prentice Hall 1988
C***END PROLOGUE  EA
      REAL ABSERR,DELTA1,DELTA2,DELTA3,EPRN,EPSTAB(*),
     1   ERROR,ERR1,ERR2,ERR3,E0,E1,E2,E3,RELPR,RES,RESULT,
     2   RES3LA(3),R1MACH,SS,SVALUE,TOL1,TOL2,TOL3
      INTEGER I,IB,IB2,IE,IERR,IN,K1,K2,K3,LIMEXP,N,NEWELM,NUM,NRES
      LOGICAL NEWFLG
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C***FIRST EXECUTABLE STATEMENT  EA
      IF(LIMEXP.LT.3) THEN
        IERR = 1
CCCCC   CALL XERROR('LIMEXP IS LESS THAN 3',21,1,1)
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,901)
  901   FORMAT('***** ERROR--NUMERICAL INTEGRATION ROUTINE EA (CALLED ',
     1         'BY QAGI ROUTINE).')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,903)
  903   FORMAT('      LIMEXP IS LESS THAN 3.')
        CALL DPWRST('XXX','BUG ')
        GO TO 110
      ENDIF
      IERR = 0
      RES3LA(1)=EPSTAB(LIMEXP+5)
      RES3LA(2)=EPSTAB(LIMEXP+6)
      RES3LA(3)=EPSTAB(LIMEXP+7)
      RESULT=SVALUE
      IF(NEWFLG) THEN
        N=1
        NRES=0
        NEWFLG=.FALSE.
        EPSTAB(N)=SVALUE
        ABSERR=ABS(RESULT)
        GO TO 100
      ELSE
        N=INT(EPSTAB(LIMEXP+3))
        NRES=INT(EPSTAB(LIMEXP+4))
        IF(N.EQ.2) THEN
          EPSTAB(N)=SVALUE
          ABSERR=.6E+01*ABS(RESULT-EPSTAB(1))
          GO TO 100
        ENDIF
      ENDIF
      EPSTAB(N)=SVALUE
      RELPR=R1MACH(4)
      EPRN=1.0E+01*RELPR
      EPSTAB(N+2)=EPSTAB(N)
      NEWELM=(N-1)/2
      NUM=N
      K1=N
      DO 40 I=1,NEWELM
        K2=K1-1
        K3=K1-2
        RES=EPSTAB(K1+2)
        E0=EPSTAB(K3)
        E1=EPSTAB(K2)
        E2=RES
        DELTA2=E2-E1
        ERR2=ABS(DELTA2)
        TOL2=MAX(ABS(E2),ABS(E1))*RELPR
        DELTA3=E1-E0
        ERR3=ABS(DELTA3)
        TOL3=MAX(ABS(E1),ABS(E0))*RELPR
        IF(ERR2.GT.TOL2.OR.ERR3.GT.TOL3) GO TO 10
C
C           IF E0, E1 AND E2 ARE EQUAL TO WITHIN MACHINE
C           ACCURACY, CONVERGENCE IS ASSUMED.
C           RESULT=E2
C           ABSERR=ABS(E1-E0)+ABS(E2-E1)
C
        RESULT=RES
        ABSERR=ERR2+ERR3
        GO TO 50
   10   IF(I.NE.1) THEN
          E3=EPSTAB(K1)
          EPSTAB(K1)=E1
          DELTA1=E1-E3
          ERR1=ABS(DELTA1)
          TOL1=MAX(ABS(E1),ABS(E3))*RELPR
C
C           IF TWO ELEMENTS ARE VERY CLOSE TO EACH OTHER, OMIT
C           A PART OF THE TABLE BY ADJUSTING THE VALUE OF N
C
          IF(ERR1.LE.TOL1.OR.ERR2.LE.TOL2.OR.ERR3.LE.TOL3) GO TO 20
          SS=0.1E+01/DELTA1+0.1E+01/DELTA2-0.1E+01/DELTA3
        ELSE
          EPSTAB(K1)=E1
          IF(ERR2.LE.TOL2.OR.ERR3.LE.TOL3) GO TO 20
          SS=0.1E+01/DELTA2-0.1E+01/DELTA3
        ENDIF
C
C           TEST TO DETECT IRREGULAR BEHAVIOUR IN THE TABLE, AND
C           EVENTUALLY OMIT A PART OF THE TABLE ADJUSTING THE VALUE
C           OF N
C
        IF(ABS(SS*E1).GT.0.1E-03) GO TO 30
   20   N=I+I-1
        IF(NRES.EQ.0) THEN
          ABSERR=ERR2+ERR3
          RESULT=RES
        ELSE IF(NRES.EQ.1) THEN
          RESULT=RES3LA(1)
        ELSE IF(NRES.EQ.2) THEN
          RESULT=RES3LA(2)
        ELSE
          RESULT=RES3LA(3)
        ENDIF
        GO TO 50
C
C           COMPUTE A NEW ELEMENT AND EVENTUALLY ADJUST
C           THE VALUE OF RESULT
C
   30   RES=E1+0.1E+01/SS
        EPSTAB(K1)=RES
        K1=K1-2
        IF(NRES.EQ.0) THEN
          ABSERR=ERR2+ABS(RES-E2)+ERR3
          RESULT=RES
          GO TO 40
        ELSE IF(NRES.EQ.1) THEN
          ERROR=.6E+01*(ABS(RES-RES3LA(1)))
        ELSE IF(NRES.EQ.2) THEN
          ERROR=.2E+01*(ABS(RES-RES3LA(2))+ABS(RES-RES3LA(1)))
        ELSE
          ERROR=ABS(RES-RES3LA(3))+ABS(RES-RES3LA(2))
     1          +ABS(RES-RES3LA(1))
        ENDIF
        IF(ERROR.GT.1.0E+01*ABSERR) GO TO 40
        ABSERR=ERROR
        RESULT=RES
   40 CONTINUE
C
C           COMPUTE ERROR ESTIMATE
C
        IF(NRES.EQ.1) THEN
          ABSERR=.6E+01*(ABS(RESULT-RES3LA(1)))
        ELSE IF(NRES.EQ.2) THEN
          ABSERR=.2E+01*ABS(RESULT-RES3LA(2))+ABS(RESULT-RES3LA(1))
        ELSE IF(NRES.GT.2) THEN
          ABSERR=ABS(RESULT-RES3LA(3))+ABS(RESULT-RES3LA(2))
     1          +ABS(RESULT-RES3LA(1))
        ENDIF
C
C           SHIFT THE TABLE
C
   50 IF(N.EQ.LIMEXP) N=2*(LIMEXP/2)-1
      IB=1
      IF((NUM/2)*2.EQ.NUM) IB=2
      IE=NEWELM+1
      DO 60 I=1,IE
        IB2=IB+2
        EPSTAB(IB)=EPSTAB(IB2)
        IB=IB2
   60 CONTINUE
      IF(NUM.EQ.N) GO TO 80
      IN=NUM-N+1
      DO 70 I=1,N
        EPSTAB(I)=EPSTAB(IN)
        IN=IN+1
   70 CONTINUE
C
C           UPDATE RES3LA
C
   80 IF(NRES.EQ.0) THEN
        RES3LA(1)=RESULT
      ELSE IF(NRES.EQ.1) THEN
        RES3LA(2)=RESULT
      ELSE IF(NRES.EQ.2) THEN
        RES3LA(3)=RESULT
      ELSE
        RES3LA(1)=RES3LA(2)
        RES3LA(2)=RES3LA(3)
        RES3LA(3)=RESULT
      ENDIF
   90 ABSERR=MAX(ABSERR,EPRN*ABS(RESULT))
      NRES=NRES+1
  100 N=N+1
*     IF(N.LE.3) ABSERR = R1MACH(2) * (0.1D-03)
      EPSTAB(LIMEXP+3)=REAL(N)
      EPSTAB(LIMEXP+4)=REAL(NRES)
      EPSTAB(LIMEXP+5)=RES3LA(1)
      EPSTAB(LIMEXP+6)=RES3LA(2)
      EPSTAB(LIMEXP+7)=RES3LA(3)
  110 RETURN
      END
      FUNCTION EI (X)
C***BEGIN PROLOGUE  EI
C***PURPOSE  Compute the exponential integral Ei(X).
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C5
C***TYPE      SINGLE PRECISION (EI-S, DEI-D)
C***KEYWORDS  EI FUNCTION, EXPONENTIAL INTEGRAL, FNLIB,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C EI calculates the single precision exponential integral, Ei(X), for
C positive single precision argument X and the Cauchy principal value
C for negative X.  If principal values are used everywhere, then, for
C all X,
C
C    Ei(X) = -E1(-X)
C or
C    E1(X) = -Ei(-X).
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  E1
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   891115  Modified prologue description.  (WRB)
C   891115  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  EI
C***FIRST EXECUTABLE STATEMENT  EI
      EI = -E1(-X)
C
      RETURN
      END
      SUBROUTINE EDGEF (NK,FC,GC,XX,YY,BFK,CDFX,POI,POJ,EPS3,IFLAG,L) 
C
C--- COMPUTE THE BETA C.D.F.'S BY A RECURRENCE RELATION ALONG THE EDGES
C--- I = IMIN AND J = JMIN OF A GRID.  THE CORRESPONDING COMPONENTS OF
C--- THE F" C.D.F. ARE INCLUDED IN THE SUMMATION.  TERMS WHICH MIGHT
C--- CAUSE UNDERFLOW ARE SET TO ZERO.
C
      DIMENSION BFK(*),POI(*),POJ(*)
      DOUBLE PRECISION DARG,DEUFLO,DLNGAM
      DATA DEUFLO / -30.0D0 / 
      FD = FC-1.0
      K = MAX0(L,MIN0(NK,INT((GC-1.0)*XX/YY-FD))) 
      FK = FD+REAL(K)
CCCCC CALL CDFBET (XX,FK,GC,EPS3,IFLAG,BFK(K))
      CALL BETCDF(XX,FK,GC,BFK(K))
CCCCC IF (IFLAG.NE.0) RETURN
      IF (L.EQ.1) BFK(K) = 1.0-BFK(K)
      IF (NK.EQ.1) GO TO 40
      DARG = DBLE(FK)*DLOG(DBLE(XX))+DBLE(GC)*DLOG(DBLE(YY))-
     *   DLOG(DBLE(FK))+DLNGAM(DBLE(FK+GC))-DLNGAM(DBLE(FK))-
     *   DLNGAM(DBLE(GC))
      IF (DARG.LT.DEUFLO) THEN
         DK = 0.0
      ELSE
         DK = SNGL(DEXP(DARG))*(-1.0)**L
      ENDIF
      IF (K.GE.NK) GO TO 20
      BFK(K+1) = BFK(K)-DK
      DI = DK
      KFLAG = 1
      DO 10 I = K+1, NK-1
         IF (KFLAG.EQ.1) THEN 
            DI = DI*(FD+GC+REAL(I-1))*XX/(FD+REAL(I))
            IF (DK+DI.EQ.DK) THEN
               KFLAG = 0
               DI = 0.0
            ENDIF
         ENDIF
         BFK(I+1) = BFK(I)-DI 
   10 CONTINUE
   20 DI = DK
      KFLAG = 1
      DO 30 I = K-1, L, -1
         IF (KFLAG.EQ.1) THEN 
            DI = DI*(FC+REAL(I))/((FD+GC+REAL(I))*XX)
            IF (DK+DI.EQ.DK) THEN
               KFLAG = 0
               DI = 0.0
            ENDIF
         ENDIF
         BFK(I) = BFK(I+1)+DI 
   30 CONTINUE
   40 DO 50 I = L, NK
         CDFX = CDFX+POI(I)*POJ(1)*BFK(I)
   50 CONTINUE
      RETURN
      END 
      SUBROUTINE EDGET(NK,FC,GC,XX,YY,BFK,CDFX,POI,POJ,EPS3,IFLAG,L) 
CCCCC CONVERT TO DOUBLE PRECISION.  SINGLE PRECISION GIVES INACCURATE
CCCCC RESULTS FOR 32-BIT MACHINES.
C
C--- COMPUTE THE BETA C.D.F.'S BY A RECURRENCE RELATION ALONG THE EDGES
C--- I = IMIN AND J = JMIN OF A GRID.  THE CORRESPONDING COMPONENTS OF
C--- THE T" C.D.F. ARE INCLUDED IN THE SUMMATION.  TERMS WHICH MIGHT
C--- CAUSE UNDERFLOW ARE SET TO ZERO.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION BFK(*),POI(*),POJ(*)
CCCCC DOUBLE PRECISION DARG,DEUFLO,DLNGAM
      DATA DEUFLO / -69.0D0 / 
      FD = FC-1.0D0
      K = MAX0(L,MIN0(NK,INT((GC-1.0D0)*XX/YY-FD))) 
      FK = FD+DBLE(K)
CCCCC CALL BETCDF(SNGL(XX),SNGL(FK),SNGL(GC),ATEMP)
      BFK(K)=DBETAI(XX,FK,GC)
C
      IF (IFLAG.NE.0) RETURN
      IF (L.EQ.1) BFK(K) = 1.0D0-BFK(K)
      IF (NK.EQ.1) GO TO 40
      DARG = FK*DLOG(XX)+GC*DLOG(YY)-
     *   DLOG(FK)+DLNGAM(FK+GC)-DLNGAM(FK)-
     *   DLNGAM(GC)
      IF (DARG.LT.DEUFLO) THEN
         DK = 0.0D0
      ELSE
         DK = DEXP(DARG)*(-1.0D0)**L
      ENDIF
      IF (K.GE.NK) GO TO 20
      BFK(K+1) = BFK(K)-DK
      DI = DK
      KFLAG = 1
      DO 10 I = K+1, NK-1
         IF (KFLAG.EQ.1) THEN 
            DI = DI*(FD+GC+DBLE(I-1))*XX/(FD+DBLE(I))
            IF (DK+DI.EQ.DK) THEN
               KFLAG = 0
               DI = 0.0D0
            ENDIF
         ENDIF
         BFK(I+1) = BFK(I)-DI 
   10 CONTINUE
   20 DI = DK
      KFLAG = 1
      DO 30 I = K-1, L, -1
         IF (KFLAG.EQ.1) THEN 
            DI = DI*(FC+DBLE(I))/((FD+GC+DBLE(I))*XX)
            IF (DK+DI.EQ.DK) THEN
               KFLAG = 0
               DI = 0.0D0
            ENDIF
         ENDIF
         BFK(I) = BFK(I+1)+DI 
   30 CONTINUE
   40 DO 50 I = L, NK
         CDFX = CDFX+POI(I)*POJ(1)*BFK(I)
   50 CONTINUE
      RETURN
      END 
      DOUBLE PRECISION FUNCTION ENVJ(N,X)
      DOUBLE PRECISION X
      ENVJ=0.5D0*DLOG10(6.28D0*N)-N*DLOG10(1.36D0*X/N)
      RETURN
      END
      SUBROUTINE EUCDIS(AMAT,AMAT2,MAXROM,MAXCOM,NR1,NC1,ICASE,IWRITE,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              EUCLIDEAN DISTANCE OF A MATRIX.  THE FORMULA IS:
C                 Dij=SQRT(SUM(Xik - Xjk)**2)
C              THE SUMMATION IS K = 1 TO P (WHERE THERE ARE P
C              COLUMNS IN THE MATRIX).  FOR EXAMPLE, D23 IS
C              THE DISTANCE BETWEEN THE SECOND AND THIRD ROWS.
C     INPUT  ARGUMENTS--AMAT   = THE SINGLE PRECISION MATRIX
C                     --MAXROM = THE INTEGER ROW DIMENSION OF AMAT
C                     --MAXCOM = THE INTEGER COUMN DIMENSION OF AMAT
C                     --NR1    = THE INTEGER NUMBER OF ROWS OF AMAT
C                     --NC1    = THE INTEGER NUMBER OF COLUMNS OF AMAT
C     OUTPUT ARGUMENTS--AMAT2    = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE EUCLIDEAN DISTANCES.
C     OUTPUT--MATRIX OF EUCLIDEAN DISTANCES
C     NOTE--THIS ROUTINE ASSUMES THE ERROR CHECKING (FOR EQUAL
C           ROWS AND COLUMNS, MATCHING DIMENSIONS FOR X AND AMAT)
C           IS DONE BT THE CALLING SUBROUTINE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98.6
C     ORIGINAL VERSION--JUNE      1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASE
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DYM1
      DOUBLE PRECISION DYM2
C
      DIMENSION AMAT(MAXROM,MAXCOM)
      DIMENSION AMAT2(MAXROM,MAXCOM)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='EUCD'
      ISUBN2='IS  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF EUCDIS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NR1,NC1
   53 FORMAT('NR1, NC1 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)ICASE
   54 FORMAT('ICASE = ',A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ********************************
C               **  COMPUTE EUCLIDEAN DISTANCE *
C               ********************************
C
      IF(ICASE.EQ.'ROW ')THEN
        DO5861I=1,NR1
          DO5863J=1,I
            IF(I.EQ.1)THEN
              AMAT2(I,I)=0.0
            ELSE
              DSUM=0.0D0
              DO5865K=1,NC1
                DYM1=AMAT(I,K)
                DYM2=AMAT(J,K)
                DSUM=DSUM+(DYM1-DYM2)**2
 5865         CONTINUE
              AMAT2(I,J)=REAL(DSQRT(DSUM))
              AMAT2(J,I)=AMAT2(I,J)
            ENDIF
 5863     CONTINUE
 5861   CONTINUE
      ELSEIF(ICASE.EQ.'COLU')THEN
        DO5961I=1,NC1
          DO5963J=1,I
            IF(I.EQ.1)THEN
              AMAT2(I,I)=0.0
            ELSE
              DSUM=0.0D0
              DO5965K=1,NR1
                DYM1=AMAT(K,I)
                DYM2=AMAT(K,J)
                DSUM=DSUM+(DYM1-DYM2)**2
 5965         CONTINUE
              AMAT2(I,J)=REAL(DSQRT(DSUM))
              AMAT2(J,I)=AMAT2(I,J)
            ENDIF
 5963     CONTINUE
 5961   CONTINUE
      ENDIF
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)
  811 FORMAT('THE EUCLIDEAN DISTANCE MATRIX HAS BEEN CALCULATED.')
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF EUCDIS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE EULERB(N,EN)
C
C       ======================================
C       Purpose: Compute Euler number En
C       Input :  n --- Serial number
C       Output:  EN(n) --- En
C       ======================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      REAL CPUMAX, CPUMIN
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
        DIMENSION EN(0:N)
C
        HPI=2.0D0/3.141592653589793D0
        DO1I=0,N
          EN(I)=0.0D0
 1      CONTINUE
C
        EN(0)=1.0D0
        EN(2)=-1.0D0
        IF(N.LE.3)RETURN
        R1=-4.0D0*HPI**3
C
        IFLAG=0
C
        DO 20 M=4,N,2
           IF(IFLAG.EQ.1)THEN
             EN(M)=DBLE(CPUMAX)
             GOTO20
           ENDIF
           R1=-R1*(M-1)*M*HPI*HPI
           R2=1.0D0
           ISGN=1.0D0
           DO 10 K=3,1000,2
              ISGN=-ISGN
              S=(1.0D0/K)**(M+1)
              R2=R2+ISGN*S
              IF (S.LT.1.0D-15) GOTO 29
10         CONTINUE
29         CONTINUE
           EN(M)=R1*R2
           IF(EN(M).GE.DBLE(CPUMAX))THEN
             IFLAG=1
             EN(M)=DBLE(CPUMAX)
             WRITE(ICOUT,90)M
             CALL DPWRST('XXX','BUG')
90           FORMAT('***** EULER NUMBERS: OVERFLOW AT N = ',I8)
           ENDIF
20      CONTINUE
C
        RETURN
        END
      SUBROUTINE EULERP(X,N,EN)
C
C       ======================================
C       Purpose: Compute Euler polynomial of order n for X
C       Input :  n --- Order of Euler polynomial
C                x --- value at which to compute the polynomial
C       Output:  EN--- computed value
C       ======================================
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION DTEMP(200)
      REAL CPUMIN, CPUMAX
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      SUM=0.0D0
      DO100I=0,N/2
        CALL EULERB(2*I,DTEMP)
        TERM2=DTEMP(2*I+1)
        TERM1=DBINOM(N,2*I)
        IF(X-0.5D0.EQ.0.0D0 .AND. N-2*I.EQ.0)THEN
          TERM3=1.0D0
        ELSE
          TERM3=(X-0.5D0)**(N-2*I)
        ENDIF
        SUM=SUM + TERM1*TERM2*TERM3/DBLE(2**(2*I))
  100 CONTINUE
      EN=SUM
C
      RETURN
      END
      SUBROUTINE EXINT (X, N, KODE, M, TOL, EN, NZ, IERR)
C***BEGIN PROLOGUE  EXINT
C***PURPOSE  Compute an M member sequence of exponential integrals
C            E(N+K,X), K=0,1,...,M-1 for N .GE. 1 and X .GE. 0.
C***LIBRARY   SLATEC
C***CATEGORY  C5
C***TYPE      SINGLE PRECISION (EXINT-S, DEXINT-D)
C***KEYWORDS  EXPONENTIAL INTEGRAL, SPECIAL FUNCTIONS
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C         EXINT computes M member sequences of exponential integrals
C         E(N+K,X), K=0,1,...,M-1 for N .GE. 1 and X .GE. 0.  The
C         exponential integral is defined by
C
C         E(N,X)=integral on (1,infinity) of EXP(-XT)/T**N
C
C         where X=0.0 and N=1 cannot occur simultaneously.  Formulas
C         and notation are found in the NBS Handbook of Mathematical
C         Functions (ref. 1).
C
C         The power series is implemented for X .LE. XCUT and the
C         confluent hypergeometric representation
C
C                     E(A,X) = EXP(-X)*(X**(A-1))*U(A,A,X)
C
C         is computed for X .GT. XCUT.  Since sequences are computed in
C         a stable fashion by recurring away from X, A is selected as
C         the integer closest to X within the constraint N .LE. A .LE.
C         N+M-1.  For the U computation, A is further modified to be the
C         nearest even integer.  Indices are carried forward or
C         backward by the two term recursion relation
C
C                     K*E(K+1,X) + X*E(K,X) = EXP(-X)
C
C         once E(A,X) is computed.  The U function is computed by means
C         of the backward recursive Miller algorithm applied to the
C         three term contiguous relation for U(A+K,A,X), K=0,1,...
C         This produces accurate ratios and determines U(A+K,A,X), and
C         hence E(A,X), to within a multiplicative constant C.
C         Another contiguous relation applied to C*U(A,A,X) and
C         C*U(A+1,A,X) gets C*U(A+1,A+1,X), a quantity proportional to
C         E(A+1,X).  The normalizing constant C is obtained from the
C         two term recursion relation above with K=A.
C
C     Description of Arguments
C
C         Input
C           X       X .GT. 0.0 for N=1 and  X .GE. 0.0 for N .GE. 2
C           N       order of the first member of the sequence, N .GE. 1
C                   (X=0.0 and N=1 is an error)
C           KODE    a selection parameter for scaled values
C                   KODE=1   returns        E(N+K,X), K=0,1,...,M-1.
C                       =2   returns EXP(X)*E(N+K,X), K=0,1,...,M-1.
C           M       number of exponential integrals in the sequence,
C                   M .GE. 1
C           TOL     relative accuracy wanted, ETOL .LE. TOL .LE. 0.1
C                   ETOL = single precision unit roundoff = R1MACH(4)
C
C         Output
C           EN      a vector of dimension at least M containing values
C                   EN(K) = E(N+K-1,X) or EXP(X)*E(N+K-1,X), K=1,M
C                   depending on KODE
C           NZ      underflow indicator
C                   NZ=0   a normal return
C                   NZ=M   X exceeds XLIM and an underflow occurs.
C                          EN(K)=0.0E0 , K=1,M returned on KODE=1
C           IERR    error flag
C                   IERR=0, normal return, computation completed
C                   IERR=1, input error,   no computation
C                   IERR=2, error,         no computation
C                           algorithm termination condition not met
C
C***REFERENCES  M. Abramowitz and I. A. Stegun, Handbook of
C                 Mathematical Functions, NBS AMS Series 55, U.S. Dept.
C                 of Commerce, 1955.
C               D. E. Amos, Computation of exponential integrals, ACM
C                 Transactions on Mathematical Software 6, (1980),
C                 pp. 365-377 and pp. 420-428.
C***ROUTINES CALLED  I1MACH, PSIXN, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   800501  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   910408  Updated the REFERENCES section.  (WRB)
C   920207  Updated with code with a revision date of 880811 from
C           D. Amos.  Included correction of argument list.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  EXINT
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      REAL             A,AA,AAMS,AH,AK,AT,B,BK,BT,CC,CNORM,CT,EM,EMX,EN,
     1                 ETOL,FNM,FX,PT,P1,P2,S,TOL,TX,X,XCUT,XLIM,XTOL,Y,
     2                 YT,Y1,Y2
      REAL             PSIXN
      INTEGER I,IC,ICASE,ICT,IERR,IK,IND,IX,I1M,JSET,K,KK,KN,KODE,KS,M,
     1        ML,MU,N,ND,NM,NZ
      DIMENSION EN(*), A(99), B(99), Y(2)
C***FIRST EXECUTABLE STATEMENT  EXINT
      IERR = 0
      NZ = 0
      ETOL = MAX(R1MACH(4),0.5E-18)
      IF (X.LT.0.0E0) IERR = 1
      IF (N.LT.1) IERR = 1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR = 1
      IF (M.LT.1) IERR = 1
      IF (TOL.LT.ETOL .OR. TOL.GT.0.1E0) IERR = 1
      IF (X.EQ.0.0E0 .AND. N.EQ.1) IERR = 1
      IF (IERR.NE.0) RETURN
      I1M = -I1MACH(12)
      PT = 2.3026E0*R1MACH(5)*I1M
      XLIM = PT - 6.907755E0
      BT = PT + (N+M-1)
      IF (BT.GT.1000.0E0) XLIM = PT - LOG(BT)
C
      XCUT = 2.0E0
      IF (ETOL.GT.2.0E-7) XCUT = 1.0E0
      IF (X.GT.XCUT) GO TO 100
      IF (X.EQ.0.0E0 .AND. N.GT.1) GO TO 80
C-----------------------------------------------------------------------
C     SERIES FOR E(N,X) FOR X.LE.XCUT
C-----------------------------------------------------------------------
      TX = X + 0.5E0
      IX = TX
C-----------------------------------------------------------------------
C     ICASE=1 MEANS INTEGER CLOSEST TO X IS 2 AND N=1
C     ICASE=2 MEANS INTEGER CLOSEST TO X IS 0,1, OR 2 AND N.GE.2
C-----------------------------------------------------------------------
      ICASE = 2
      IF (IX.GT.N) ICASE = 1
      NM = N - ICASE + 1
      ND = NM + 1
      IND = 3 - ICASE
      MU = M - IND
      ML = 1
      KS = ND
      FNM = NM
      S = 0.0E0
      XTOL = 3.0E0*TOL
      IF (ND.EQ.1) GO TO 10
      XTOL = 0.3333E0*TOL
      S = 1.0E0/FNM
   10 CONTINUE
      AA = 1.0E0
      AK = 1.0E0
      IC = 35
      IF (X.LT.ETOL) IC = 1
      DO 50 I=1,IC
        AA = -AA*X/AK
        IF (I.EQ.NM) GO TO 30
        S = S - AA/(AK-FNM)
        IF (ABS(AA).LE.XTOL*ABS(S)) GO TO 20
        AK = AK + 1.0E0
        GO TO 50
   20   CONTINUE
        IF (I.LT.2) GO TO 40
        IF (ND-2.GT.I .OR. I.GT.ND-1) GO TO 60
        AK = AK + 1.0E0
        GO TO 50
   30   S = S + AA*(-LOG(X)+PSIXN(ND))
        XTOL = 3.0E0*TOL
   40   AK = AK + 1.0E0
   50 CONTINUE
      IF (IC.NE.1) GO TO 340
   60 IF (ND.EQ.1) S = S + (-LOG(X)+PSIXN(1))
      IF (KODE.EQ.2) S = S*EXP(X)
      EN(1) = S
      EMX = 1.0E0
      IF (M.EQ.1) GO TO 70
      EN(IND) = S
      AA = KS
      IF (KODE.EQ.1) EMX = EXP(-X)
      GO TO (220, 240), ICASE
   70 IF (ICASE.EQ.2) RETURN
      IF (KODE.EQ.1) EMX = EXP(-X)
      EN(1) = (EMX-S)/X
      RETURN
   80 CONTINUE
      DO 90 I=1,M
        EN(I) = 1.0E0/(N+I-2)
   90 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C     BACKWARD RECURSIVE MILLER ALGORITHM FOR
C              E(N,X)=EXP(-X)*(X**(N-1))*U(N,N,X)
C     WITH RECURSION AWAY FROM N=INTEGER CLOSEST TO X.
C     U(A,B,X) IS THE SECOND CONFLUENT HYPERGEOMETRIC FUNCTION
C-----------------------------------------------------------------------
  100 CONTINUE
      EMX = 1.0E0
      IF (KODE.EQ.2) GO TO 130
      IF (X.LE.XLIM) GO TO 120
      NZ = M
      DO 110 I=1,M
        EN(I) = 0.0E0
  110 CONTINUE
      RETURN
  120 EMX = EXP(-X)
  130 CONTINUE
      IX = X+0.5E0
      KN = N + M - 1
      IF (KN.LE.IX) GO TO 140
      IF (N.LT.IX .AND. IX.LT.KN) GO TO 170
      IF (N.GE.IX) GO TO 160
      GO TO 340
  140 ICASE = 1
      KS = KN
      ML = M - 1
      MU = -1
      IND = M
      IF (KN.GT.1) GO TO 180
  150 KS = 2
      ICASE = 3
      GO TO 180
  160 ICASE = 2
      IND = 1
      KS = N
      MU = M - 1
      IF (N.GT.1) GO TO 180
      IF (KN.EQ.1) GO TO 150
      IX = 2
  170 ICASE = 1
      KS = IX
      ML = IX - N
      IND = ML + 1
      MU = KN - IX
  180 CONTINUE
      IK = KS/2
      AH = IK
      JSET = 1 + KS - (IK+IK)
C-----------------------------------------------------------------------
C     START COMPUTATION FOR
C              EN(IND) = C*U( A , A ,X)    JSET=1
C              EN(IND) = C*U(A+1,A+1,X)    JSET=2
C     FOR AN EVEN INTEGER A.
C-----------------------------------------------------------------------
      IC = 0
      AA = AH + AH
      AAMS = AA - 1.0E0
      AAMS = AAMS*AAMS
      TX = X + X
      FX = TX + TX
      AK = AH
      XTOL = TOL
      IF (TOL.LE.1.0E-3) XTOL = 20.0E0*TOL
      CT = AAMS + FX*AH
      EM = (AH+1.0E0)/((X+AA)*XTOL*SQRT(CT))
      BK = AA
      CC = AH*AH
C-----------------------------------------------------------------------
C     FORWARD RECURSION FOR P(IC),P(IC+1) AND INDEX IC FOR BACKWARD
C     RECURSION
C-----------------------------------------------------------------------
      P1 = 0.0E0
      P2 = 1.0E0
  190 CONTINUE
      IF (IC.EQ.99) GO TO 340
      IC = IC + 1
      AK = AK + 1.0E0
      AT = BK/(BK+AK+CC+IC)
      BK = BK + AK + AK
      A(IC) = AT
      BT = (AK+AK+X)/(AK+1.0E0)
      B(IC) = BT
      PT = P2
      P2 = BT*P2 - AT*P1
      P1 = PT
      CT = CT + FX
      EM = EM*AT*(1.0E0-TX/CT)
      IF (EM*(AK+1.0E0).GT.P1*P1) GO TO 190
      ICT = IC
      KK = IC + 1
      BT = TX/(CT+FX)
      Y2 = (BK/(BK+CC+KK))*(P1/P2)*(1.0E0-BT+0.375E0*BT*BT)
      Y1 = 1.0E0
C-----------------------------------------------------------------------
C     BACKWARD RECURRENCE FOR
C              Y1=             C*U( A ,A,X)
C              Y2= C*(A/(1+A/2))*U(A+1,A,X)
C-----------------------------------------------------------------------
      DO 200 K=1,ICT
        KK = KK - 1
        YT = Y1
        Y1 = (B(KK)*Y1-Y2)/A(KK)
        Y2 = YT
  200 CONTINUE
C-----------------------------------------------------------------------
C     THE CONTIGUOUS RELATION
C              X*U(B,C+1,X)=(C-B)*U(B,C,X)+U(B-1,C,X)
C     WITH  B=A+1 , C=A IS USED FOR
C              Y(2) = C * U(A+1,A+1,X)
C     X IS INCORPORATED INTO THE NORMALIZING RELATION
C-----------------------------------------------------------------------
      PT = Y2/Y1
      CNORM = 1.0E0 - PT*(AH+1.0E0)/AA
      Y(1) = 1.0E0/(CNORM*AA+X)
      Y(2) = CNORM*Y(1)
      IF (ICASE.EQ.3) GO TO 210
      EN(IND) = EMX*Y(JSET)
      IF (M.EQ.1) RETURN
      AA = KS
      GO TO (220, 240), ICASE
C-----------------------------------------------------------------------
C     RECURSION SECTION  N*E(N+1,X) + X*E(N,X)=EMX
C-----------------------------------------------------------------------
  210 EN(1) = EMX*(1.0E0-Y(1))/X
      RETURN
  220 K = IND - 1
      DO 230 I=1,ML
        AA = AA - 1.0E0
        EN(K) = (EMX-AA*EN(K+1))/X
        K = K - 1
  230 CONTINUE
      IF (MU.LE.0) RETURN
      AA = KS
  240 K = IND
      DO 250 I=1,MU
        EN(K+1) = (EMX-X*EN(K))/AA
        AA = AA + 1.0E0
        K = K + 1
  250 CONTINUE
      RETURN
  340 CONTINUE
      IERR = 2
      RETURN
      END
      SUBROUTINE ERRCDF(X,ALPHA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE ERROR (OR EXPONENTIAL POWER OR
C              GENERAL ERROR OR SUBBOTIN) DISTRIBUTION.  NOTE THAT
C              THERE ARE SEVERAL DIFFERENT PARAMETERIZATIONS OF
C              THIS DISTRIBUTION.  WE USE THE ONE FROM THE
C              TADIKAMALLA PAPER (SEE REFERENCE BELOW).  SPECIFICALLY,
C              THE PDF IS:
C              F(X,ALPHA)=EXP(-|X|**ALPHA)/[2*ALPHA(1+1/ALPHA)]
C                         -INFINITY < X < INFINITY, ALPHA >= 1
C              WITH ALPHA DENOTING THE SHAPE PARAMETER.
C              AT THE VALUE ALPHA.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE CUMULATIVE DISTRIBUTION 
C                                FUNCTION IS TO BE EVALUATED.
C                                X CAN BE ANY REAL NUMBER
C                     --ALPHA  = THE SINGLE PRECISION VALUE 
C                                OF THE TAIL LENGTH PARAMETER.
C                                ALPHA SHOULD BE >= 1..
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--ALPHA SHOULD BE >= 1.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DGAMMA, DGAMI
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--PANDU R. RADIKAMALLA, "RANDOM SAMPLING FROM THE
C                 EXPONENTIAL POWER DISTRIBUTION", JOURNAL OF THE
C                 AMERICAN STATISTICAL ASSOCIATION, SEPTEMBER, 1980,
C                 PAGES 683-686.
C               --JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 2, SECOND EDITION",
C                 WILEY, 1994.
C               --EVANS, HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--THIRD EDITION", WILEY, 2000.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--MAY       2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX,DALPHA,DGAMMA,DGAMI,DCDF
      DOUBLE PRECISION DTERM1, DTERM2
      EXTERNAL DGAMI
      EXTERNAL DGAMMA
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(ALPHA.LT.1.0)THEN
        WRITE(ICOUT,15) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,16) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
   15 FORMAT('***** FATAL ERROR--THE SHAPE PARAMETER FOR THE ERROR')
   16 FORMAT('      CDF FUNCTION IS LESS THAN ONE.')
   46 FORMAT('      THE VALUE OF THE ARGUMENT IS ',E15.8)
C
C-----START POINT-----------------------------------------------------
C
      DX=DBLE(X)
      DALPHA=DBLE(ALPHA)
C
C  ALPHA=1 IS DOUBLE EXPONENTIAL
C  ALPHA=2 IS NORMAL
C
      IF(ALPHA.LE.1.00005)THEN
        CALL DEXCDF(X,CDF)
        GOTO9999
      ELSEIF(ALPHA.EQ.2.0)THEN
        CALL NORCDF(X,CDF)
        GOTO9999
      ENDIF
C
      IF(X.EQ.0.0)THEN
        CDF=0.5
        GOTO9999
      ELSEIF(X.GT.0.0)THEN
        DTERM1=-DX*DGAMI(1.0D0/DALPHA,DX**DALPHA)
        DTERM2=2.0D0*DALPHA*(DX**DALPHA)**(1.0D0/DALPHA)*
     1         DGAMMA(1.0D0+1.0D0/DALPHA)
        DCDF=0.5D0 - DTERM1/DTERM2
      ELSE
        DX=-DX
        DTERM1=-DX*DGAMI(1.0D0/DALPHA,DX**DALPHA)
        DTERM2=2.0D0*DALPHA*(DX**DALPHA)**(1.0D0/DALPHA)*
     1         DGAMMA(1.0D0+1.0D0/DALPHA)
        DCDF=0.5D0 + DTERM1/DTERM2
      ENDIF
C
      CDF=REAL(DCDF)
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE ERRPDF(X,ALPHA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE ERROR (OR EXPONENTIAL POWER OR
C              GENERAL ERROR OR SUBBOTIN) DISTRIBUTION.  NOTE THAT
C              THERE ARE SEVERAL DIFFERENT PARAMETERIZATIONS OF
C              THIS DISTRIBUTION.  WE USE THE ONE FROM THE
C              TADIKAMALLA PAPER (SEE REFERENCE BELOW).  SPECIFICALLY,
C              THE PDF IS:
C              F(X,ALPHA)=EXP(-|X|**ALPHA)/[2*ALPHA(1+1/ALPHA)]
C                         -INFINITY < X < INFINITY, ALPHA >= 1
C              WITH ALPHA DENOTING THE SHAPE PARAMETER.
C              AT THE VALUE ALPHA.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE CUMULATIVE DISTRIBUTION 
C                                FUNCTION IS TO BE EVALUATED.
C                                X CAN BE ANY REAL NUMBER
C                     --ALPHA  = THE SINGLE PRECISION VALUE 
C                                OF THE TAIL LENGTH PARAMETER.
C                                ALPHA SHOULD BE >= 1..
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--ALPHA SHOULD BE >= 1.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--PANDU R. RADIKAMALLA, "RANDOM SAMPLING FROM THE
C                 EXPONENTIAL POWER DISTRIBUTION", JOURNAL OF THE
C                 AMERICAN STATISTICAL ASSOCIATION, SEPTEMBER, 1980,
C                 PAGES 683-686.
C               --JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 2, SECOND EDITION",
C                 WILEY, 1994.
C               --EVANS, HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--THIRD EDITION", WILEY, 2000.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--MAY       2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C

      DOUBLE PRECISION DX,DALPHA,DLNGAM,DPDF
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(ALPHA.LT.1.0)THEN
        WRITE(ICOUT,15) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,16) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   15 FORMAT('***** FATAL ERROR--THE SHAPE PARAMETER FOR THE ERROR')
   16 FORMAT('      PDF FUNCTION IS LESS THAN ONE.')
   46 FORMAT('      THE VALUE OF THE ARGUMENT IS ',E15.8)
C
C-----START POINT-----------------------------------------------------
C
      DX=DBLE(X)
      DALPHA=DBLE(ALPHA)
C
      IF(ALPHA.EQ.1.0)THEN
        CALL DEXPDF(X,PDF)
        GOTO9999
      ELSEIF(ALPHA.EQ.2.0)THEN
        CALL NORPDF(X,PDF)
        GOTO9999
      ENDIF
C
      DPDF=-DABS(DX)**DALPHA-DLOG(2.0D0)-DLNGAM(1.0D0+1.0D0/DALPHA)
      IF(DPDF.LT.-80.D0)THEN
        PDF=0.0
      ELSEIF(DPDF.LT.LOG(CPUMAX))THEN
        PDF=REAL(DEXP(DPDF))
      ELSE
        PDF=LOG(CPUMAX)
        WRITE(ICOUT,105) 
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
  105 FORMAT('****** WARNING--OVERFLOW IN ERRPDF ROUTINE.')
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE ERRPPF(P,ALPHA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE ERROR (OR EXPONENTIAL POWER OR
C              GENERAL ERROR OR SUBBOTIN) DISTRIBUTION.  NOTE THAT
C              THERE ARE SEVERAL DIFFERENT PARAMETERIZATIONS OF
C              THIS DISTRIBUTION.  WE USE THE ONE FROM THE
C              TADIKAMALLA PAPER (SEE REFERENCE BELOW).  SPECIFICALLY,
C              THE PPF IS:
C              F(X,ALPHA)=EXP(-|X|**ALPHA)/[2*ALPHA(1+1/ALPHA)]
C                         -INFINITY < X < INFINITY, ALPHA >= 1
C              WITH ALPHA DENOTING THE SHAPE PARAMETER.
C              AT THE VALUE ALPHA.
C              THE PERCENT POINT FUNCTION IS COMPUTED NUMERICALLY
C              USING A BISECTION METHOD.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE PERCENT POINT 
C                                FUNCTION IS TO BE EVALUATED.
C                                X CAN BE ANY REAL NUMBER
C                     --ALPHA  = THE SINGLE PRECISION VALUE 
C                                OF THE TAIL LENGTH PARAMETER.
C                                ALPHA SHOULD BE >= 1..
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--ALPHA SHOULD BE >= 1.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--PANDU R. RADIKAMALLA, "RANDOM SAMPLING FROM THE
C                 EXPONENTIAL POWER DISTRIBUTION", JOURNAL OF THE
C                 AMERICAN STATISTICAL ASSOCIATION, SEPTEMBER, 1980,
C                 PAGES 683-686.
C               --JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 2, SECOND EDITION",
C                 WILEY, 1994.
C               --EVANS, HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--THIRD EDITION", WILEY, 2000.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--MAY       2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX,DALPHA,DGAMMA
      EXTERNAL DGAMMA
C
      DATA EPS /0.00001/
      DATA SIG /1.0E-6/
      DATA ZERO /0./
      DATA MAXIT /500/
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0 .OR. P.GE.1.0)THEN
        WRITE(ICOUT,5) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
      IF(ALPHA.LT.1.0)THEN
        WRITE(ICOUT,15) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,16) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE INPUT ARGUMENT FOR THE ERROR')
    6 FORMAT('      PERCENT POINT FUNCTION IS OUTSIDE THE ALLOWABLE ',
     1       '[0,1] INTERVAL.')
   15 FORMAT('***** FATAL ERROR--THE SHAPE PARAMETER FOR THE ERROR')
   16 FORMAT('      PERCENT POINT FUNCTION IS LESS THAN ONE.')
   46 FORMAT('      THE VALUE OF THE ARGUMENT IS ',E15.8)
C
C-----START POINT-----------------------------------------------------
C
      IF(ALPHA.LE.1.00005)THEN
        CALL DEXPPF(P,PPF)
        ASGN=1.0
        GOTO9999
      ELSEIF(ALPHA.EQ.2.0)THEN
        CALL NORPPF(P,PPF)
        ASGN=1.0
        GOTO9999
      ENDIF
C
      DALPHA=DBLE(ALPHA)
C
C  P = 0.5 IS ZERO.  USE SYMMETRY TO HANDLE P < 0.5 AND P > 0.5
C  CASES WITH SAME CODE (JUST NEED TO CHANGE SIGN OF FINAL PPF
C  VALUE).
C
      IF(P.EQ.0.5)THEN
        PPF=0.0
        GOTO9999
      ENDIF
      ASGN=1.0
      IF(P.LT.0.5)THEN
        P=1.0 - P
        ASGN=-1.0
      ENDIF
C
C  FIND BRACKETING INTERVAL.  BRACKETED ABOVE BY ZERO.  STANDARD
C  DEVIATION = SQRT(GAMMA(3/ALPHA)/GAMMA(1/ALPHA)).
C
      SD=DSQRT(DGAMMA(3.0D0/DALPHA)/DGAMMA(1.0D0/DALPHA))
      XL=0.0D0
      XINC=SD
      ICOUNT=0
      MAXCNT=200
C
   91 CONTINUE
      XR=XL+XINC
      IF(XL.LE.0.0)XL=0.0
      IF(XR.LE.0.0)XR=XL+1.0
      CALL ERRCDF(XL,ALPHA,CDFL)
      CALL ERRCDF(XR,ALPHA,CDFR)
      IF(CDFL.LT.P .AND. CDFR.LT.P)THEN
        XL=XR
      ELSEIF(CDFL.GT.P .AND. CDFR.GT.P)THEN
        XL=XL-XINC
      ELSE
        GOTO99
      ENDIF
      ICOUNT=ICOUNT+1
      IF(ICOUNT.GT.MAXCNT)THEN
        WRITE(ICOUT,96)
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
   96 FORMAT('***** FATAL ERROR--ERRPPF UNABLE TO FIND BRACKETING ',
     *       'INTERVAL. *****')
      GOTO91
C
C  BISECTION METHOD
C
   99 CONTINUE
      IC = 0
      FXL = -P
      FXR = 1.0 - P
  105 CONTINUE
      X = (XL+XR)*0.5
      CALL ERRCDF(X,ALPHA,CDF)
      P1=CDF
      PPF=X
      FCS = P1 - P
      IF(FCS*FXL.GT.ZERO)GOTO110
      XR = X
      FXR = FCS 
      GOTO115
  110 CONTINUE
      XL = X
      FXL = FCS
  115 CONTINUE
      XRML = XR - XL
      IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999
      IC = IC + 1
      IF(IC.LE.MAXIT)GOTO105
      WRITE(ICOUT,130)
      CALL DPWRST('XXX','BUG ')
  130 FORMAT('***** FATAL ERROR--ERRPPF ROUTINE DID NOT CONVERGE. ***')
      GOTO9999
C
C
 9999 CONTINUE
      PPF=ASGN*PPF
      RETURN
      END 
      SUBROUTINE ERRRAN(N,ALPHA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE ERROR DISTRIBUTION WITH SINGLE PRECISION SHAPE
C              PARAMETER = ALPHA.  THIS DISTRIBUTION IS ALSO REFERRED
C              TO AS THE SUBBOTIN, EXPONENTIAL POWER, OR GENERAL
C              ERROR DISTRIBUTION.  NOTE THAT
C              THERE ARE SEVERAL DIFFERENT PARAMETERIZATIONS OF
C              THIS DISTRIBUTION.  WE USE THE ONE FROM THE
C              TADIKAMALLA PAPER (SEE REFERENCE BELOW).  SPECIFICALLY,
C              THE PDF IS:
C              F(X,ALPHA)=EXP(-|X|**ALPHA)/[2*ALPHA(1+1/ALPHA)]
C                         -INFINITY < X < INFINITY, ALPHA >= 1
C              WITH ALPHA DENOTING THE SHAPE PARAMETER.
C              AT THE VALUE ALPHA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE SINGLE PRECISION VALUE OF THE
C                                FIRST  SHAPE PARAMETER.
C                                ALPHA SHOULD BE GREATER THAN 1.0.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE ERROR DISTRIBUTION
C             WITH SHAPE PARAMETER VALUE = ALPHA
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALPHA SHOULD BE GREATER THAN
C                   OR EQUAL TO 1.0.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, GAMRAN, DEXRAN,
C                                         GAMRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--PANDU R. RADIKAMALLA, "RANDOM SAMPLING FROM THE
C                 EXPONENTIAL POWER DISTRIBUTION", JOURNAL OF THE
C                 AMERICAN STATISTICAL ASSOCIATION, SEPTEMBER, 1980,
C                 PAGES 683-686.
C               --JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 2, SECOND EDITION",
C                 WILEY, 1994.
C               --EVANS, HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--THIRD EDITION", WILEY, 2000.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLARITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2003.5
C     ORIGINAL VERSION--MAY       2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION XTEMP(1)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(ALPHA.LT.1.0)THEN
        WRITE(ICOUT,16)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE NUMBER OF REQUESTED ERROR ',
     1'RANDOM NUMBERS IS NON-POSITIVE.')
   16 FORMAT('***** FATAL ERROR--THE SHAPE PARAMETER FOR THE ',
     1'ERROR DISTRIBUTION IS LESS THAN 1.0 *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N ERROR RANDOM NUMBERS USING THE ALGORITHM OF
C     RADIKAMALLA.  THIS IS A FORTRAN IMPLEMENTATION OF THE ROUTINE
C     "gsl_ran_exppow" IN THE GNU GSL SCIENTIFIC LIBRARY.
C
      NTEMP=1
C
C  FIRST, HANDLE SPECIAL CASES (ALPHA = 1, 2 ARE DOUBLE EXPONENTIAL
C  AND NORMAL, RESPECTIVELY).
C
      IF(ALPHA.EQ.1.0)THEN
        CALL DEXRAN(N,ISEED,X)
      ELSEIF(ALPHA.EQ.2.0)THEN
        CALL NORRAN(N,ISEED,X)
C
C  CASE WHERE 1 < ALPHA < 2.  USE DOUBLE EXPONENTIAL DISTRIBUTION
C  FOR REJECTION METHOD.
C
      ELSEIF(ALPHA.GT.1.0 .AND. ALPHA.LT.2.0)THEN
        S=1.4489
        DO390I=1,N
  300     CONTINUE
            CALL DEXRAN(NTEMP,ISEED,XTEMP)
            AX=XTEMP(1)
            CALL DEXPDF(AX,AY)
            CALL ERRPDF(AX,ALPHA,AH)
            RATIO=AH/(S*AY)
            CALL UNIRAN(NTEMP,ISEED,XTEMP)
            U=XTEMP(1)
          IF(U.GT.RATIO)GOTO300
          X(I)=AX
  390   CONTINUE
C
C  CASE WHERE ALPHA > 2.  USE GAUSSIAN FOR FOR REJECTION METHOD.
C
      ELSE
        SIGMA=1.0/1.0/SQRT(2.0)
        S=2.4091
        DO490I=1,N
  400     CONTINUE
            CALL NORRAN(NTEMP,ISEED,XTEMP)
            AX=SIGMA*XTEMP(1)
            CALL NORPDF(AX/SIGMA,AY)
            AY=AY/SIGMA
            CALL ERRPDF(AX,ALPHA,AH)
            RATIO=AH/(S*AY)
            CALL UNIRAN(NTEMP,ISEED,XTEMP)
            U=XTEMP(1)
          IF(U.GT.RATIO)GOTO400
          X(I)=AX
  490   CONTINUE
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE ERRORF(IANS1,IANS2,IANS3,IANS4,AMIN,AMAX,DEF,
     1ANS2,IERROR)
C
C     PURPOSE--ANALYZE FLOATING POINT INPUT TERMINAL RESPONSE DURING
C              EXECUTION OF DATAPLOT AND
C              DETERMINE IF VALID.
C              ALSO, MAKE CONVERSION TO FLOATING POINT.
C     INPUT  ARGUMENTS--IANS1
C                     --IANS2
C                     --IANS3
C                     --IANS4
C                     --AMIN
C                     --AMAX
C                     --DEF
C     OUTPUT ARGUMENTS--ANS2
C                     --IERROR
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER 18, 1976.
C     UPDATED         --OCTOBER   1976.
C     UPDATED         --JULY      1978.
C     UPDATED         --OCTOBER   1978.
C     UPDATED         --FEBRUARY  1981.
C     UPDATED         --FEBRUARY  1982.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IANS1
      CHARACTER*4 IANS2
      CHARACTER*4 IANS3
      CHARACTER*4 IANS4
      CHARACTER*4 IERROR
C
      CHARACTER*4 IBUG1
      CHARACTER*4 IBUG2
      CHARACTER*4 IA
C
C---------------------------------------------------------------------
C
      DIMENSION IA(20)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ANS2=0
      IERROR='NO'
      IBUG1='OFF'
      IBUG2='OFF'
C
C               ************************************************************
C               **  DEFINE NUMASC = NUMBER OF ASCII CHARACTERS PER WORD.  **
C               **  THIS IS 4 REGARDLESS OF THE COMPUTER MAKE AND         **
C               **  REGARDLESS OF THE WORD SIZE.                          **
C               ************************************************************
C
      NUMASC=4
      NUMAS2=2*NUMASC
      NUMAS3=3*NUMASC
C
C               *******************************
C               **  STEP 1--                 **
C               **  CHECK FOR BLANK ENTRIES  **
C               *******************************
C
      IF(IANS1.EQ.'    '.AND.IANS2.EQ.'    '.AND.IANS3.EQ.'    '.AND.
     1IANS4.EQ.'    ')GOTO105
      GOTO110
  105 CONTINUE
      ANS2=DEF
      IF(AMIN.LE.ANS2.AND.ANS2.LE.AMAX)GOTO9000
      GOTO1750
  110 CONTINUE
C
C               *******************************************************
C               **  STEP 2--                                         **
C               **  DECOMPOSE THE INPUT WORDS                        **
C               **  IANS1, IANS2, IANS3, AND IANS4                   **
C               **  INTO 16 NUMBPC-BIT CHUNKS                        **
C               **  WHERE NUMBPC = NUMBER OF BITS PER CHARACTER      **
C               **  FOR THIS COMPUTER.                               **
C               **  EACH NUMBPC-BIT CHUNK WILL (BY CONSTRUCTION)     **
C               **  BE STORED                                        **
C               **  IN A LEFT-JUSTIFIED FASHION IN IA(.)             **
C               **  WITH (BY CONSTRUCTION) BLANK-FILL TO THE RIGHT.  **
C               *******************************************************
C
      DO150I=1,16
      IA(I)='    '
  150 CONTINUE
      DO200I=1,4
      ISTAR3=NUMBPC*(I-1)
      ISTAR3=IABS(ISTAR3)
      I1=I
      I2=I1+NUMASC
      I3=I1+NUMAS2
      I4=I1+NUMAS3
      CALL DPCHEX(ISTAR3,NUMBPC,IANS1,0,NUMBPC,IA(I1))
      CALL DPCHEX(ISTAR3,NUMBPC,IANS2,0,NUMBPC,IA(I2))
      CALL DPCHEX(ISTAR3,NUMBPC,IANS3,0,NUMBPC,IA(I3))
      CALL DPCHEX(ISTAR3,NUMBPC,IANS4,0,NUMBPC,IA(I4))
  200 CONTINUE
      IF(IBUG1.EQ.'OFF')GOTO350
      DO300I=1,16
      WRITE(ICOUT,305)IA(I)
  305 FORMAT(A4)
      CALL DPWRST('XXX','BUG ')
  300 CONTINUE
  350 CONTINUE
C
C               **********************************************
C               **  STEP 3--                                **
C               **  CHECK FOR AN EXIT, END, STOP, OR TERM.  **
C               **********************************************
C
      DO500I=1,16
      IP1=I+1
      IP2=I+2
      IP3=I+3
      IF(IA(I).EQ.'E'.AND.IA(IP1).EQ.'X'.AND.IA(IP2).EQ.'I'
     1.AND.IA(IP3).EQ.'T')GOTO510
      IF(IA(I).EQ.'E'.AND.IA(IP1).EQ.'N'.AND.IA(IP2).EQ.'D')
     1GOTO510
      IF(IA(I).EQ.'S'.AND.IA(IP1).EQ.'T'.AND.IA(IP2).EQ.'O'
     1.AND.IA(IP3).EQ.'P')GOTO510
      IF(IA(I).EQ.'T'.AND.IA(IP1).EQ.'E'.AND.IA(IP2).EQ.'R'
     1.AND.IA(IP3).EQ.'M')GOTO510
  500 CONTINUE
      GOTO550
  510 WRITE(ICOUT,520)
  520 FORMAT('THIS IS AN EXIT FROM DATAPLOT ')
      CALL DPWRST('XXX','BUG ')
      STOP
  550 CONTINUE
C
C               *********************************
C               **  STEP 4--                   **
C               **  CONVERT TO FLOATING POINT  **
C               *********************************
C
C               ************************************************************
C               **  STEP 4.1--                                            **
C               **  FIRST OF ALL, LOCATE THE DECIMAL POINT (IF EXISTENT)  **
C               ************************************************************
C
      ILOC=0
      IDECPT=0
      DO1000I=1,16
      IF(IA(I).EQ.'.')ILOC=I
      IF(IA(I).EQ.'.')IDECPT=IDECPT+1
 1000 CONTINUE
      IF(IDECPT.GE.2)GOTO1530
      IF(IDECPT.EQ.1)GOTO1150
      DO1100I=1,16
      IREV=16-I+1
      IF(IA(IREV).EQ.' ')GOTO1100
      IF(IA(IREV).EQ.'0')GOTO1110
      IF(IA(IREV).EQ.'1')GOTO1110
      IF(IA(IREV).EQ.'2')GOTO1110
      IF(IA(IREV).EQ.'3')GOTO1110
      IF(IA(IREV).EQ.'4')GOTO1110
      IF(IA(IREV).EQ.'5')GOTO1110
      IF(IA(IREV).EQ.'6')GOTO1110
      IF(IA(IREV).EQ.'7')GOTO1110
      IF(IA(IREV).EQ.'8')GOTO1110
      IF(IA(IREV).EQ.'9')GOTO1110
      IF(IA(IREV).EQ.'+')GOTO1530
      IF(IA(IREV).EQ.'-')GOTO1530
 1100 CONTINUE
      GOTO1530
 1110 ILOC=IREV+1
 1150 CONTINUE
      IF(IBUG2.EQ.'ON')WRITE(ICOUT,1111)ILOC,IDECPT
 1111 FORMAT('ILOC = ',I8,'    IDECPT = ',I8)
      IF(IBUG2.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
C               *******************************************************
C               **  STEP 4.2--                                       **
C               **  SECONDLY, COMPUTE THE INTEGER PART OF THE VALUE  **
C               *******************************************************
C
      SIGN=1.0
      IDIGI=0
      ISIGN=0
      SUMI=0
      ILOCM1=ILOC-1
      IF(ILOCM1.LT.1)GOTO1250
      DO1200I=1,ILOCM1
      IREV=ILOCM1-I+1
      IF(IA(IREV).EQ.' ')GOTO1200
      IF(IA(IREV).EQ.'0')GOTO1210
      IF(IA(IREV).EQ.'1')GOTO1211
      IF(IA(IREV).EQ.'2')GOTO1212
      IF(IA(IREV).EQ.'3')GOTO1213
      IF(IA(IREV).EQ.'4')GOTO1214
      IF(IA(IREV).EQ.'5')GOTO1215
      IF(IA(IREV).EQ.'6')GOTO1216
      IF(IA(IREV).EQ.'7')GOTO1217
      IF(IA(IREV).EQ.'8')GOTO1218
      IF(IA(IREV).EQ.'9')GOTO1219
      IF(IA(IREV).EQ.'+')GOTO1220
      IF(IA(IREV).EQ.'-')GOTO1221
      GOTO1530
 1210 ITERM=0
      GOTO1225
 1211 ITERM=1
      GOTO1225
 1212 ITERM=2
      GOTO1225
 1213 ITERM=3
      GOTO1225
 1214 ITERM=4
      GOTO1225
 1215 ITERM=5
      GOTO1225
 1216 ITERM=6
      GOTO1225
 1217 ITERM=7
      GOTO1225
 1218 ITERM=8
      GOTO1225
 1219 ITERM=9
      GOTO1225
 1220 ISIGN=ISIGN+1
      GOTO1200
 1221 ISIGN=ISIGN+1
      SIGN=-SIGN
      GOTO1200
 1225 IDIGI=IDIGI+1
      TERM=ITERM
      IEXP=IDIGI-1
      SUMI=SUMI+TERM*(10.0**IEXP)
 1200 CONTINUE
 1250 CONTINUE
      IF(ISIGN.GE.2)GOTO1530
      IF(IBUG2.EQ.'ON')WRITE(ICOUT,1255)IDIGI,SUMI
 1255 FORMAT('IDIGI = ',I8,'    SUMI = ',F20.10)
      IF(IBUG2.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
C               ******************************************************
C               **  STEP 4.3--                                      **
C               **  THIRDLY, COMPUTE THE DECIMAL PART OF THE VALUE  **
C               ******************************************************
C
      IDIGD=0
      SUMD=0.0
      ILOCP1=ILOC+1
      IF(ILOCP1.GT.16)GOTO1350
      DO1300I=ILOCP1,16
      IF(IA(I).EQ.' ')GOTO1300
      IF(IA(I).EQ.'0')GOTO1310
      IF(IA(I).EQ.'1')GOTO1311
      IF(IA(I).EQ.'2')GOTO1312
      IF(IA(I).EQ.'3')GOTO1313
      IF(IA(I).EQ.'4')GOTO1314
      IF(IA(I).EQ.'5')GOTO1315
      IF(IA(I).EQ.'6')GOTO1316
      IF(IA(I).EQ.'7')GOTO1317
      IF(IA(I).EQ.'8')GOTO1318
      IF(IA(I).EQ.'9')GOTO1319
      GOTO1530
 1310 ITERM=0
      GOTO1325
 1311 ITERM=1
      GOTO1325
 1312 ITERM=2
      GOTO1325
 1313 ITERM=3
      GOTO1325
 1314 ITERM=4
      GOTO1325
 1315 ITERM=5
      GOTO1325
 1316 ITERM=6
      GOTO1325
 1317 ITERM=7
      GOTO1325
 1318 ITERM=8
      GOTO1325
 1319 ITERM=9
      GOTO1325
 1325 IDIGD=IDIGD+1
      TERM=ITERM
      SUMD=SUMD+TERM/(10.0**IDIGD)
 1300 CONTINUE
 1350 CONTINUE
      IF(IBUG2.EQ.'ON')WRITE(ICOUT,1355)IDIGD,SUMD
 1355 FORMAT('IDIGD = ',I8,'    SUMD = ',F20.10)
      IF(IBUG2.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IDIGT=IDIGI+IDIGD
      IF(IDIGT.LE.0)GOTO1530
      ANS2=SUMI+SUMD
      IF(SIGN.LT.0.0)ANS2=-ANS2
      IF(AMIN.LE.ANS2.AND.ANS2.LE.AMAX)GOTO9000
      GOTO1750
C
 1530 CONTINUE
      WRITE(ICOUT,1531)
 1531 FORMAT('***** ERROR IN ERRORF--LAST ENTRY WAS ',
     1'INVALID ***')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1532)
 1532 FORMAT('      IT SHOULD HAVE BEEN SOME INTEGER OR ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1533)
 1533 FORMAT('      FLOATING POINT NUMBER, BUT WAS NOT.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1534)IANS1,IANS2,IANS3,IANS4
 1534 FORMAT('      THE ENTRY WAS ',4A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1535)
 1535 FORMAT('      REENTER PROPER VALUE NOW--')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 1750 CONTINUE
      WRITE(ICOUT,1531)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1752)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1753)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1754)AMIN,AMAX
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1755)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1734)IANS1,IANS2,IANS3,IANS4
 1734 FORMAT('      THE ENTRY WAS ',4A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1735)
 1735 FORMAT('      REENTER PROPER VALUE NOW--')
      CALL DPWRST('XXX','BUG ')
 1752 FORMAT('      IT SHOULD HAVE BEEN SOME INTEGER OR ')
 1753 FORMAT('      FLOATING POINT NUMBER ')
 1754 FORMAT('      BETWEEN ',E15.7,' AND ',E15.7,' (INCLUSIVE),')
 1755 FORMAT('      BUT WAS NOT.')
      IERROR='YES'
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      RETURN
      END
      subroutine ess(y,n,len,ideg,njump,userw,rw,ys,res)
c
c  This routine is part of the Bill Cleveland seasonal loess
c  program.
c
      integer n, len, ideg, njump, newnj, nleft, nright, nsh, k, i, j
      real y(n), rw(n), ys(n), res(n), delta
      logical ok, userw
      if(.not.(n .lt. 2))goto 23019
      ys(1) = y(1)
      return
23019 continue
      newnj = min0(njump, n-1)
      if(.not.(len .ge. n))goto 23021
      nleft = 1
      nright = n
      do 23023 i = 1,n,newnj 
      call est(y,n,len,ideg,float(i),ys(i),nleft,nright,res,userw,rw,ok)
      if(.not.( .not. ok))goto 23025
      ys(i) = y(i)
23025 continue
23023 continue
      goto 23022
23021 continue
      if(.not.(newnj .eq. 1))goto 23027
      nsh = (len+1)/2
      nleft = 1
      nright = len
      do 23029 i = 1,n 
      if(.not.(i .gt. nsh  .and.  nright .ne. n))goto 23031
      nleft = nleft+1
      nright = nright+1
23031 continue
      call est(y,n,len,ideg,float(i),ys(i),nleft,nright,res,userw,rw,ok)
      if(.not.( .not. ok))goto 23033
      ys(i) = y(i)
23033 continue
23029 continue
      goto 23028
23027 continue
      nsh = (len+1)/2
      do 23035 i = 1,n,newnj 
      if(.not.(i .lt. nsh))goto 23037
      nleft = 1
      nright = len
      goto 23038
23037 continue
      if(.not.(i .ge. n-nsh+1))goto 23039
      nleft = n-len+1
      nright = n
      goto 23040
23039 continue
      nleft = i-nsh+1
      nright = len+i-nsh
23040 continue
23038 continue
      call est(y,n,len,ideg,float(i),ys(i),nleft,nright,res,userw,rw,ok)
      if(.not.( .not. ok))goto 23041
      ys(i) = y(i)
23041 continue
23035 continue
23028 continue
23022 continue
      if(.not.(newnj .ne. 1))goto 23043
      do 23045 i = 1,n-newnj,newnj 
      delta = (ys(i+newnj)-ys(i))/float(newnj)
      do 23047 j = i+1,i+newnj-1
      ys(j) = ys(i)+delta*float(j-i)
23047 continue
23045 continue
      k = ((n-1)/newnj)*newnj+1
      if(.not.(k .ne. n))goto 23049
      call est(y,n,len,ideg,float(n),ys(n),nleft,nright,res,userw,rw,ok)
      if(.not.( .not. ok))goto 23051
      ys(n) = y(n)
23051 continue
      if(.not.(k .ne. n-1))goto 23053
      delta = (ys(n)-ys(k))/float(n-k)
      do 23055 j = k+1,n-1
      ys(j) = ys(k)+delta*float(j-k)
23055 continue
23053 continue
23049 continue
23043 continue
      return
      end
      subroutine est(y,n,len,ideg,xs,ys,nleft,nright,w,userw,rw,ok)
c
c  This routine is part of the Bill Cleveland seasonal loess
c  program.
c
      integer n, len, ideg, nleft, nright, j
      real y(n), w(n), rw(n), xs, ys, range, h, h1, h9, a, b, c, r
      logical userw,ok
      range = float(n)-float(1)
      h = amax1(xs-float(nleft),float(nright)-xs)
      if(.not.(len .gt. n))goto 23057
      h = h+float((len-n)/2)
23057 continue
      h9 = .999*h
      h1 = .001*h
      a = 0.0
      do 23059 j = nleft,nright 
      w(j) = 0.
      r = abs(float(j)-xs)
      if(.not.(r .le. h9))goto 23061
      if(.not.(r .le. h1))goto 23063
      w(j) = 1.
      goto 23064
23063 continue
      w(j) = (1.0-(r/h)**3)**3
23064 continue
      if(.not.(userw))goto 23065
      w(j) = rw(j)*w(j)
23065 continue
      a = a+w(j)
23061 continue
23059 continue
      if(.not.(a .le. 0.0))goto 23067
      ok = .false.
      goto 23068
23067 continue
      ok = .true.
      do 23069 j = nleft,nright
      w(j) = w(j)/a
23069 continue
      if(.not.((h .gt. 0.) .and. (ideg .gt. 0)))goto 23071
      a = 0.0
      do 23073 j = nleft,nright
      a = a+w(j)*float(j)
23073 continue
      b = xs-a
      c = 0.0
      do 23075 j = nleft,nright
      c = c+w(j)*(float(j)-a)**2
23075 continue
      if(.not.(sqrt(c) .gt. .001*range))goto 23077
      b = b/c
      do 23079 j = nleft,nright
      w(j) = w(j)*(b*(float(j)-a)+1.0)
23079 continue
23077 continue
23071 continue
      ys = 0.0
      do 23081 j = nleft,nright
      ys = ys+w(j)*y(j)
23081 continue
23068 continue
      return
      end
      SUBROUTINE EV1CDF(X,MINMAX,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE EXTREME VALUE TYPE 1
C              DISTRIBUTION.
C              THE EXTREME VALUE TYPE 1 DISTRIBUTION USED
C              HEREIN HAS MEAN = EULER'S NUMBER = 0.57721566
C              AND STANDARD DEVIATION = PI/SQRT(6) = 1.28254983.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              FOR THE MAXIMUM ORDER STATISTIC
C              F(X) = (EXP(-X)) * (EXP(-(EXP(-X))))
C              WHICH SIMPLIFIES TO:
C              F(X) = EXP(-X - EXP(-X))
C              FOR THE MINIMUIM ORDER STATISTIC
C              F(X) = (EXP(X)) * (EXP(-(EXP(X))))
C              WHICH SIMPLIFIES TO:
C              F(X) = EXP(X-EXP(X))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE CUMULATIVE DISTRIBUTION 
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE EXTREME VALUE TYPE 1
C             DISTRIBUTION WITH MEAN = EULER'S NUMBER = 0.57721566
C             AND STANDARD DEVIATION = PI/SQRT(6) = 1.28254983.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 272-295.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994. 
C     UPDATED         --JULY      2005. CODE IN DOUBLE PRECIONS FOR
C                                       BETTER ACCURACY
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DCDF
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C     NO INPUT ARGUMENT ERRORS POSSIBLE 
C     FOR THIS DISTRIBUTION.
C
C-----START POINT-----------------------------------------------------
C
      DX=DBLE(X)
      IF(MINMAX.EQ.1)THEN
        DCDF=1.0D0-DEXP(-(DEXP(DX))) 
      ELSEIF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
        DCDF=DEXP(-(DEXP(-DX))) 
      ELSE
         WRITE(ICOUT,1800)
 1800    FORMAT('*****ERROR IN EV1CDF--MINMAX NOT 1 OR 2')
         CALL DPWRST('XXX','BUG ')
      END IF
      CDF=REAL(DCDF)
C
      RETURN
      END 
      SUBROUTINE EV1CDD(X,MINMAX,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE EXTREME VALUE TYPE 1
C              DISTRIBUTION.
C              THE EXTREME VALUE TYPE 1 DISTRIBUTION USED
C              HEREIN HAS MEAN = EULER'S NUMBER = 0.57721566
C              AND STANDARD DEVIATION = PI/SQRT(6) = 1.28254983.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              FOR THE MAXIMUM ORDER STATISTIC
C              F(X) = (EXP(-X)) * (EXP(-(EXP(-X))))
C              WHICH SIMPLIFIES TO:
C              F(X) = EXP(-X - EXP(-X))
C              FOR THE MINIMUIM ORDER STATISTIC
C              F(X) = (EXP(X)) * (EXP(-(EXP(X))))
C              WHICH SIMPLIFIES TO:
C              F(X) = EXP(X-EXP(X))
C     NOTE  --THIS IS A DOUBLE PRECISION VERSION OF EV1CDF USED
C             IN CALCULATING HAZARD FUNCTIONS.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE CUMULATIVE DISTRIBUTION 
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE EXTREME VALUE TYPE 1
C             DISTRIBUTION WITH MEAN = EULER'S NUMBER = 0.57721566
C             AND STANDARD DEVIATION = PI/SQRT(6) = 1.28254983.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 272-295.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION X
      DOUBLE PRECISION CDF
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C     NO INPUT ARGUMENT ERRORS POSSIBLE 
C     FOR THIS DISTRIBUTION.
C
C-----START POINT-----------------------------------------------------
C
      IF(MINMAX.EQ.1)THEN
        CDF=1.0D0-DEXP(-(DEXP(X))) 
      ELSEIF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
        CDF=DEXP(-(DEXP(-X))) 
      ELSE
         WRITE(ICOUT,1800)
 1800    FORMAT('*****ERROR IN EV1CDF--MINMAX NOT 1 OR 2')
         CALL DPWRST('XXX','BUG ')
      END IF
C
      RETURN
      END 
      SUBROUTINE EV1CHA(X,MINMAX,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE EXTREME VALUE TYPE 1
C              DISTRIBUTION.
C              THE EXTREME VALUE TYPE 1 DISTRIBUTION USED
C              HEREIN HAS MEAN = EULER'S NUMBER = 0.57721566
C              AND STANDARD DEVIATION = PI/SQRT(6) = 1.28254983.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              FOR THE MAXIMUM ORDER STATISTIC
C              F(X) = (EXP(-X)) * (EXP(-(EXP(-X))))
C              WHICH SIMPLIFIES TO:
C              F(X) = EXP(-X - EXP(-X))
C              FOR THE MINIMUIM ORDER STATISTIC
C              F(X) = (EXP(X)) * (EXP(-(EXP(X))))
C              WHICH SIMPLIFIES TO:
C              F(X) = EXP(-X - EXP(-X))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE CUMULATIVE DISTRIBUTION 
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION CUMULATIVE HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD
C             FUNCTION VALUE FOR THE EXTREME VALUE TYPE 1
C             DISTRIBUTION WITH MEAN = EULER'S NUMBER = 0.57721566
C             AND STANDARD DEVIATION = PI/SQRT(6) = 1.28254983.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 272-295.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--APRIL     1998. 
C     UPDATED         --JUNE      1999. SIMPLIFY FORMULAS
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CCCCC DOUBLE PRECISION CDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C     NO INPUT ARGUMENT ERRORS POSSIBLE 
C     FOR THIS DISTRIBUTION.
C
C-----START POINT-----------------------------------------------------
C
      IF(MINMAX.EQ.1)THEN
        HAZ=EXP(X)
CCCCC   CALL EV1CDD(DBLE(X),MINMAX,CDF)
CCCCC   IF(1.0D0-CDF.LE.0.0D0)THEN
CCCCC     WRITE(ICOUT,1100)
C1100     FORMAT('*****ERROR IN EV1CHA--CDF ESSENTIALLY 1.')
CCCCC     CALL DPWRST('XXX','BUG ')
CCCCC   ELSE
CCCCC     HAZ=REAL(-DLOG(1.0D0-CDF))
CCCCC   ENDIF
      ELSEIF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
        DX=DBLE(X)
        DTERM1=DEXP(-DEXP(-DX))
        DTERM2=1.0D0-DTERM1
        IF(DTERM2.GT.0.0D0)THEN
          HAZ=REAL(-DLOG(DTERM2))
        ELSE
          WRITE(ICOUT,1100)
          CALL DPWRST('XXX','BUG ')
          HAZ=0.0
        ENDIF
 1100   FORMAT('*****ERROR IN EV1CHA--UNABLE TO COMPUTE CUMULATIVE',
     1         'HAZARD FUNCTION.')
CCCCC   CALL EV1CDD(DBLE(X),MINMAX,CDF)
CCCCC   IF(1.0D0-CDF.LE.0.0D0)THEN
CCCCC     WRITE(ICOUT,1100)
CCCCC     CALL DPWRST('XXX','BUG ')
CCCCC   ELSE
CCCCC     HAZ=REAL(-DLOG(1.0D0-CDF))
CCCCC   ENDIF
      ELSE
        HAZ=0.0
        WRITE(ICOUT,1800)
 1800   FORMAT('*****ERROR IN EV1CHA--MINMAX NOT 1 OR 2')
        CALL DPWRST('XXX','BUG ')
      END IF
C
      RETURN
      END 
      SUBROUTINE EV1EST(X,NOBS,ALOC,SCALE,ALOC2,SCALE2,MINMAX,IERROR)
C
C  COMPUTE MLES FOR SCALE PARAMETER (SCALE) AND LOCATION
C  PARAMETER (ALOC) BY SOLVING THE EQUATION
C     G(SCALE)=0, WHERE G IS
C  A MONOTONICALLY INCREASING FUNCTION OF SCALE.
C  THE INITIAL ESTIMATE IS THE METHOD OF MOMENTS ESTIMATOR
C  AND THE TOLERANCE IS   :   2*RI/(10**6).
C
      DIMENSION X(*)
C
      REAL GFM, GFM2
      REAL SCALEL, SCALEH, SCALEM
      REAL TOL
C
      CHARACTER*4 IBUGA3
      CHARACTER*4 IWRITE
      CHARACTER*4 IERROR
C
      IERROR='NO'
      RN=REAL(NOBS)
C
C  USE METHOD OF MOMENTS TO GET INITAL ESTIMATES OF LOCATION AND SCALE
C
      IBUGA3='OFF'
      IWRITE='OFF'
      CALL MEAN(X,NOBS,IWRITE,XMEAN,IBUGA3,IERROR)
      CALL SD(X,NOBS,IWRITE,XSD,IBUGA3,IERROR)
      SCALEM=SQRT(1.645)*XSD
      IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
        ALOCM=XMEAN-0.5772*XSD
      ELSE
        ALOCM=XMEAN+0.5772*XSD
      ENDIF
      ALOC2=ALOCM
      SCALE2=SCALEM
C
      TOL=2.0*.000001*SCALEM
      CALL EV1FUN(X,NOBS,XMEAN,ALOCM,SCALEM,GFM,MINMAX)
C
C  IF G(SCALEM) .GE. 0, DIVIDE THE INITIAL ESTIMATE BY 2 UNTIL
C  THE ROOT IS BRACKETED BY SCALEL AND SCALEH.
C
      IF(GFM.GE.0.0D0)THEN
           SCALEH=SCALEM/2.0
           CALL EV1FUN(X,NOBS,XMEAN,ALOCM,SCALEM,GFM2,MINMAX)
           DCONST=2.0
           IF(GFM2.GT.GFM)DCONST=0.5
           DO 3 J=1,200
                SCALEH=SCALEM
                SCALEM=SCALEM/DCONST
                CALL EV1FUN(X,NOBS,XMEAN,ALOCM,SCALEM,GFM,MINMAX)
                IF(GFM.LE.0.0)GO TO 4
    3      CONTINUE
           IERROR='YES'
           GOTO9999
    4      CONTINUE
           SCALEL=SCALEM
C
C  IF G(SCALEM) .LT. 0, MULTIPLY THE INITIAL ESTIMATE BY 2 UNTIL
C  THE ROOT IS BRACKETED BY SCALEL AND SCALEH.
      ELSEIF(GFM.LT.0.0)THEN
           SCALEH=SCALEM/2.0
           CALL EV1FUN(X,NOBS,XMEAN,ALOCM,SCALEM,GFM2,MINMAX)
           DCONST=2.0
           IF(GFM2.LT.GFM)DCONST=0.5
           DO 7 J=1,2000
                SCALEL=SCALEM
                SCALEM=SCALEM*DCONST
                CALL EV1FUN(X,NOBS,XMEAN,ALOCM,SCALEM,GFM,MINMAX)
                IF(GFM.GE.0.0D0)GO TO 8
    7      CONTINUE
           IERROR='YES'
           GOTO9999
    8      CONTINUE
           SCALEH=SCALEM
      ENDIF
C
C SOLVE THE EQUATION G(SCALE)=0 FOR SCALE BY BISECTING THE
C   INTERVAL (SCALEL,SCALEH) UNTIL THE TOLERANCE IS MET
      MAXIT=20000
      NIT=0
   10 CONTINUE
      SCALEM=(SCALEL+SCALEH)/2.0
      CALL EV1FUN(X,NOBS,XMEAN,ALOCM,SCALEM,GFM,MINMAX)
      IF(GFM.GE.0.0)THEN
           SCALEH=SCALEM
      ENDIF
      IF(GFM.LT.0.0)THEN
           SCALEL=SCALEM
      ENDIF
      NIT=NIT+1
C
      IF(NIT.GT.MAXIT)THEN
        IERROR='YES'
        SCALE=(SCALEL+SCALEH)/2.0
        ALOC=ALOCM
        GOTO9999
      ENDIF
C
      IF(SCALEH-SCALEL.GT.TOL)GO TO 10
C
      SCALE=(SCALEL+SCALEH)/2.0
      ALOC=ALOCM
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE EV1FUN(X,N,XMEAN,ALOC,SCALE,EV1VAL,MINMAX)
C
C   COMPUTE G FUNCTION USED IN ESTIMATING THE SHAPE AND SCALE
C   PARAMETERS FOR EV1 DISTRIBUTION.
C
      DOUBLE PRECISION DN, DSUM1, DSUM2, DTERM1, DX, DSCALE
      DIMENSION X(*)
C
C  CALCULATE SOME INTERMEDIATE VALUES
C
      IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
        DN=DBLE(N)
        DSCALE=DBLE(SCALE)
        DSUM1=0.0
        DSUM2=0.0
        DO100I=1,N
          DX=DBLE(X(I))
          DSUM1=DSUM1 + DEXP(-DX/DSCALE)
          DSUM2=DSUM2 + DX*DEXP(-DX/DSCALE)
  100   CONTINUE
C
        ALOC=-SCALE*DLOG(DSUM1/DN)
C
        DTERM1=DBLE(XMEAN) - DSUM2/DSUM1
        EV1VAL=SCALE - REAL(DTERM1)
C
      ELSE
        DN=DBLE(N)
        DSCALE=DBLE(SCALE)
        DSUM1=0.0
        DSUM2=0.0
        DO200I=1,N
          DX=DBLE(X(I))
          DSUM1=DSUM1 + DEXP(DX/DSCALE)
          DSUM2=DSUM2 + DX*DEXP(DX/DSCALE)
  200   CONTINUE
C
        ALOC=SCALE*DLOG(DSUM1/DN)
C
        DTERM1=-DBLE(XMEAN) + DSUM2/DSUM1
        EV1VAL=SCALE - REAL(DTERM1)
C
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION EV1FU2 (SHAT,X)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE MAXIMUM LIKELIHOOD
C              ESTIMATE OF THE SCALE PARAMETER FOR THE GUMBEL
C              MODEL FOR FULL SAMPLE DATA (NO CENSORING).  THIS
C              FUNCTION FINDS THE ROOT OF THE EQUATION:
C
C              FOR THE MAXIMUM CASE:
C
C                 SHAT - XBAR + SUM[i=1 to N][X(I)*EXP(-X(I)/SHAT)]/
C                        SUM[i=1 to N][EXP(-X(I)/SHAT)] = 0
C
C              FOR THE MINIMUM CASE:
C
C                 SHAT - XBAR + SUM[i=1 to N][X(I)*EXP(X(I)/SHAT)]/
C                        SUM[i=1 to N][EXP(X(I)/SHAT)] = 0
C
C              WITH
C
C                 SHAT     = CURRENT ESTIMATE OF SCALE PARAMETER
C                 XBAR     = SAMPLE MEAN
C                 N        = SAMPLE SIZE
C                 MINMAX   = SPECIFY WHETHER MAXIMUM OR MINIMUM
C                            CASE IS BEING ESTIMATED
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.
C     EXAMPLE--GUMBEL MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 15.
C              --JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS
C                UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                WILEY, 1994, CHAPTER xx.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/12
C     ORIGINAL VERSION--DECEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION SHAT
      DOUBLE PRECISION X(*)
C
      INTEGER N 
      DOUBLE PRECISION XBAR
      COMMON/EV1CO2/XBAR,MINMAX,N
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      DSUM1=0.0D0
      DSUM2=0.0D0
C
      IF(MINMAX.EQ.2)THEN
        DO100I=1,N
          DSUM1=DSUM1 + X(I)*DEXP(-X(I)/SHAT)
          DSUM2=DSUM2 + DEXP(-X(I)/SHAT)
  100   CONTINUE
        EV1FU2=SHAT - XBAR + DSUM1/DSUM2
      ELSE
        DO200I=1,N
          DSUM1=DSUM1 + X(I)*DEXP(X(I)/SHAT)
          DSUM2=DSUM2 + DEXP(X(I)/SHAT)
  200   CONTINUE
        EV1FU2=SHAT + XBAR - DSUM1/DSUM2
      ENDIF
C
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION EV1FU3 (SHAT,X)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDECE INTERVALS FOR THE LOCATION AND SCALE
C              PARAMETERS OF A GUMBEL DISTRIBUTION.
C              THIS FUNCTION FINDS THE ROOT OF THE EQUATION:
C
C                 2*LL(MU,SIGMA) - 2*LL(M(sigma),sigma)
C                                - CHSPPF(alpha,1)
C
C              WITH
C
C                 LL(MU,SIGMA) = -N*LOG(SIGMA) - N*XBAR/SIGMA +
C                                N*MU/SIGMA -
C                                SUM[i=1 to N][EXP(-(X(I)-MU)/SIGMA)]
C
C              GIVEN CURRENT VALUE OF SIGMA (= SHAT),
C
C                 MU(SIGMA) = -SIGMA*LOG(SUM[i=1 to N][EXP(-X(I)/SIGMA)]/N]
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.
C     EXAMPLE--GUMBEL MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 15.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/12
C     ORIGINAL VERSION--DECEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION SHAT
      DOUBLE PRECISION X(*)
C
      INTEGER N 
      DOUBLE PRECISION XBAR
      COMMON/EV1CO2/XBAR,MINMAX,N
      DOUBLE PRECISION DK, DLLUS
      COMMON/EV1CO3/DK, DLLUS
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DSUM1
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C
C  GIVEN SIGMA, COMPUTE ESTIMATE OF MU
C
      DSUM1=0.0D0
      DN=DBLE(N)
C
      IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
        DO100I=1,N
          DSUM1=DSUM1 + DEXP(-X(I)/SHAT)
  100   CONTINUE
        DMU=-SHAT*DLOG(DSUM1/DN)
      ELSE
        DO200I=1,N
          DSUM1=DSUM1 + DEXP(X(I)/SHAT)
  200   CONTINUE
        DMU=SHAT*DLOG(DSUM1/DN)
      ENDIF
C
C  COMPUTE SOME SUMS
C
      DSUM1=0.0D0
C
      IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
        DO300I=1,N
          DSUM1=DSUM1 + DEXP(-(X(I) - DMU)/SHAT)
  300   CONTINUE
        DTERM1=-DN*DLOG(SHAT) - DN*XBAR/SHAT + DN*DMU/SHAT - DSUM1
      ELSE
        DO400I=1,N
          DSUM1=DSUM1 + DEXP((X(I) + DMU)/SHAT)
  400   CONTINUE
        DTERM1=-DN*DLOG(SHAT) - DN*XBAR/SHAT + DN*DMU/SHAT - DSUM1
      ENDIF
C
      EV1FU3=2.0D0*DLLUS - 2.0D0*DTERM1 - DK
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION EV1FU4 (DMU,X)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDECE INTERVALS FOR THE LOCATION AND SCALE
C              PARAMETERS OF A GUMBEL DISTRIBUTION.
C              THIS FUNCTION FINDS THE ROOT OF THE EQUATION:
C
C                 2*LL(MU,SIGMA) - 2*LL(mu,sigma(mu))
C                                - CHSPPF(alpha,1)
C
C              WITH
C
C                 LL(MU,SIGMA) = -N*LOG(SIGMA) - N*XBAR/SIGMA +
C                                N*MU/SIGMA -
C                                SUM[i=1 to N][EXP(-(X(I)-MU)/SIGMA)]
C
C              GIVEN CURRENT VALUE OF MU (= DMU), SIGMA IS ROOT OF:
C
C                 SIGMA + MU +
C                 SUM[i=1 to n][X(I)*EXP(-(X(I)-MU)/SIGMA]/N - 
C                 MU*SUM[i=1 to n][EXP(-(X(I)-MU)/SIGMA]/N -  XBAR
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.
C     EXAMPLE--GUMBEL MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 15.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/12
C     ORIGINAL VERSION--DECEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DMU
      DOUBLE PRECISION X(*)
C
      INTEGER N 
      DOUBLE PRECISION XBAR
      COMMON/EV1CO2/XBAR,MINMAX,N
      DOUBLE PRECISION DLLUS
      DOUBLE PRECISION DK
      COMMON/EV1CO3/DK, DLLUS
      DOUBLE PRECISION SHAT
      COMMON/EV1CO4/SHAT
      DOUBLE PRECISION DMU2
      COMMON/EV1CO5/DMU2
      DOUBLE PRECISION EV1FU5
      EXTERNAL EV1FU5
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION AE
      DOUBLE PRECISION RE
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XSTRT
      DOUBLE PRECISION SHAT2
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  STEP 1: GIVEN VALUE OF LOCATION PARAMETER (MU), NEED TO COMPUTE
C          THE SCALE PARAMETER (WHICH IN TURN INVOLVES FINDING A
C          ROOT).
C
      DMU2=DMU
C
      AE=1.D-7
      RE=1.D-7
      XSTRT=SHAT
      XLOW=XSTRT/2.0D0
      XUP=XSTRT*2.0D0
      CALL DFZER3(EV1FU5,XLOW,XUP,XSTRT,RE,AE,IFLAG,X)
      SHAT2=XLOW
C
      DSUM1=0.0D0
      DN=DBLE(N)
C
C  COMPUTE SOME SUMS
C
      DSUM1=0.0D0
C
      IF(MINMAX.EQ.2 .OR. MINMAX.EQ.2)THEN
        DO300I=1,N
          DSUM1=DSUM1 + DEXP(-(X(I) - DMU)/SHAT2)
  300   CONTINUE
        DTERM1=-DN*DLOG(SHAT2) - DN*XBAR/SHAT2 + DN*DMU/SHAT2 - DSUM1
      ELSE
        DO400I=1,N
          DSUM1=DSUM1 + DEXP((X(I) + DMU)/SHAT2)
  400   CONTINUE
        DTERM1=-DN*DLOG(SHAT2) - DN*XBAR/SHAT2 + DN*DMU/SHAT2 - DSUM1
      ENDIF
C
      EV1FU4=2.0D0*DLLUS - 2.0D0*DTERM1 - DK
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION EV1FU5 (SHAT,X)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDECE INTERVALS FOR THE LOCATION AND SCALE
C              PARAMETERS OF A GUMBEL DISTRIBUTION.
C              THIS CONFIDENCE INTERVAL IS THE ROOT OF THE EQUATION
C
C                 2*LL(MU,SIGMA) - 2*LL(mu,sigma(mu))
C                                - CHSPPF(alpha,1)
C
C              WITH
C
C                 LL(MU,SIGMA) = -N*LOG(SIGMA) - N*XBAR/SIGMA +
C                                N*MU/SIGMA -
C                                SUM[i=1 to N][EXP(-(X(I)-MU)/SIGMA)]
C
C              GIVEN CURRENT VALUE OF MU (= DMU), SIGMA IS ROOT OF:
C
C                 SIGMA + MU +
C                 SUM[i=1 to n][X(I)*EXP(-(X(I)-MU)/SIGMA]/N - 
C                 MU*SUM[i=1 to n][EXP(-(X(I)-MU)/SIGMA]/N -  XBAR
C
C              EV1FU5 IS USED IN SOLVING FOR THE VALUE OF SIGMA
C              GIVEN MU.
C
C              CALLED BY DFZER3 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.
C     EXAMPLE--GUMBEL MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 15.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/12
C     ORIGINAL VERSION--DECEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION SHAT
      DOUBLE PRECISION X(*)
C
      INTEGER N 
      DOUBLE PRECISION XBAR
      COMMON/EV1CO2/XBAR,MINMAX,N
      DOUBLE PRECISION DMU
      COMMON/EV1CO5/DMU
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C
C  GIVEN MU, FIND ROOT FOR SIGMA
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DN=DBLE(N)
C
      IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
        DO100I=1,N
          DSUM1=DSUM1 + X(I)*DEXP(-(X(I)-DMU)/SHAT)
          DSUM2=DSUM2 + DEXP(-(X(I)-DMU)/SHAT)
  100   CONTINUE
        EV1FU5=SHAT + DMU + DSUM1/DN - DMU*DSUM2/DN - XBAR
      ELSE
        DO200I=1,N
          DSUM1=DSUM1 + X(I)*DEXP((X(I)+DMU)/SHAT)
          DSUM2=DSUM2 + DEXP((X(I)+DMU)/SHAT)
  200   CONTINUE
        EV1FU5=SHAT + DMU + DSUM1/DN - DMU*DSUM2/DN - XBAR
      ENDIF
C
C  COMPUTE SOME SUMS
C
C
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION EV1FU6 (DPPF,X)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDECE INTERVALS FOR THE LOCATION AND SCALE
C              PARAMETERS OF A GUMBEL DISTRIBUTION.
C              THIS FUNCTION FINDS THE ROOT OF THE EQUATION:
C
C                 2*LL(MU,SIGMA) - 2*LL(mu(Q),S1(Q)
C                                - CHSPPF(alpha,1)
C
C              WITH
C
C                 LL(MU,SIGMA) = -N*LOG(SIGMA) - N*XBAR/SIGMA +
C                                N*MU/SIGMA -
C                                SUM[i=1 to N][EXP(-(X(I)-MU)/SIGMA)]
C
C              GIVEN A VALUE OF Q, EV1FU6 IS CALLED TO DETERMINE A
C              VALUE OF SIGMA.  THEN THE FOLLOWING IS USED TO
C              FIND THE VALUE OF M.
C
C                 MU = Q + LN(LN(1/q))*SHAT
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.
C     EXAMPLE--GUMBEL MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 15.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/12
C     ORIGINAL VERSION--DECEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION X(*)
C
      DOUBLE PRECISION EV1FU7
      EXTERNAL EV1FU7
C
      INTEGER N 
      DOUBLE PRECISION XBAR
      COMMON/EV1CO2/XBAR,MINMAX,N
      DOUBLE PRECISION DLLUS
      DOUBLE PRECISION DK
      COMMON/EV1CO3/DK, DLLUS
      DOUBLE PRECISION DQ
      DOUBLE PRECISION SHATML
      COMMON/EV1CO6/DQ,SHATML
      DOUBLE PRECISION DQ2
      DOUBLE PRECISION DPPF2
      COMMON/EV1CO7/DQ2,DPPF2
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DMU
      DOUBLE PRECISION SHAT2
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION AE
      DOUBLE PRECISION RE
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XSTRT
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  STEP 1: GIVEN VALUE OF Q, NEED TO COMPUTE
C          THE SCALE PARAMETER (WHICH IN TURN INVOLVES FINDING A
C          ROOT).
C
      DQ2=DQ
      DPPF2=DPPF
C
      AE=1.D-7
      RE=1.D-7
      XSTRT=SHATML
      XLOW=XSTRT/5.0D0
      XUP=XSTRT*5.0D0
      CALL DFZER3(EV1FU7,XLOW,XUP,XSTRT,RE,AE,IFLAG,X)
      SHAT2=XLOW
C
C  STEP 2: NOW COMPUTE VALUE OF MU
C
      DMU=DPPF + DLOG(DLOG(1.0D0/DQ))*SHAT2
C
C  COMPUTE SOME SUMS
C
      DN=DBLE(N)
      DSUM1=0.0D0
C
      IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
        DO300I=1,N
          DSUM1=DSUM1 + DEXP(-(X(I) - DMU)/SHAT2)
  300   CONTINUE
        DTERM1=-DN*DLOG(SHAT2) - DN*XBAR/SHAT2 + DN*DMU/SHAT2 - DSUM1
      ELSE
        DO400I=1,N
          DSUM1=DSUM1 + DEXP((X(I) + DMU)/SHAT2)
  400   CONTINUE
        DTERM1=-DN*DLOG(SHAT2) - DN*XBAR/SHAT2 + DN*DMU/SHAT2 - DSUM1
      ENDIF
C
      EV1FU6=2.0D0*DLLUS - 2.0D0*DTERM1 - DK
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION EV1FU7 (SHAT,X)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDECE INTERVALS FOR A PERCENTILE OF THE
C              GUMBEL DISTRIBUTION.  THIS FUNCTION FINDS THE ROOT
C              OF THE EQUATION:
C
C              (N/SIGMA)*{(XBAR - Q)/SIGMA + (LOG(q)/N)*
C              SUM[i=1 to N][EXP(-(X(I)-Q)/SIGMA)*(X(I)-Q)/SIGMA)] - 1
C
C              WITH
C
C                 q       = DESIRED PERCENTILE (E.G., 0.95) (DQ IN CODE)
C                 Q       = POINT ESTIMATE OF PERCENTILE (EV1PPF(q) =
C                           DPPF IN CODE)
C
C              EV1FU7 IS USED IN SOLVING FOR THE VALUE OF SIGMA
C              GIVEN q AND Q.
C
C              CALLED BY DFZER3 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.
C     EXAMPLE--GUMBEL MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 15.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/12
C     ORIGINAL VERSION--DECEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION SHAT
      DOUBLE PRECISION X(*)
C
      INTEGER N 
      DOUBLE PRECISION XBAR
      COMMON/EV1CO2/XBAR,MINMAX,N
      DOUBLE PRECISION DQ
      DOUBLE PRECISION DPPF
      COMMON/EV1CO7/DQ,DPPF
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DTERM1
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C
C  GIVEN MU, FIND ROOT FOR SIGMA
C
      DSUM1=0.0D0
      DN=DBLE(N)
      DTERM1=(XBAR-DPPF)/SHAT
C
      IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
        DO100I=1,N
          DSUM1=DSUM1 + ((X(I)-DPPF)/SHAT)*DEXP(-(X(I)-DPPF)/SHAT)
  100   CONTINUE
      ELSE
        DO200I=1,N
          DSUM1=DSUM1 + ((X(I)-DPPF)/SHAT)*DEXP((X(I)-DPPF)/SHAT)
  200   CONTINUE
      ENDIF
C
      EV1FU7=(DN/SHAT)*(DTERM1 + (DLOG(DQ)/DN)*DSUM1 - 1.0D0)
C
      RETURN
      END
      SUBROUTINE EV1HAZ(X,MINMAX,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE EXTREME VALUE TYPE 1
C              DISTRIBUTION.
C              THE EXTREME VALUE TYPE 1 DISTRIBUTION USED
C              HEREIN HAS MEAN = EULER'S NUMBER = 0.57721566
C              AND STANDARD DEVIATION = PI/SQRT(6) = 1.28254983.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              FOR THE MAXIMUM ORDER STATISTIC
C              F(X) = (EXP(-X)) * (EXP(-(EXP(-X))))
C              WHICH SIMPLIFIES TO:
C              F(X) = EXP(-X - EXP(-X))
C              FOR THE MINIMUIM ORDER STATISTIC
C              F(X) = (EXP(X)) * (EXP(-(EXP(X))))
C              WHICH SIMPLIFIES TO:
C              F(X) = EXP(-X - EXP(-X))
C              THE HAZARD FUNCTION IS:
C              EXP(-X)/(EXP(EXP(-X)-1))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE CUMULATIVE DISTRIBUTION 
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION HAZARD
C             FUNCTION VALUE FOR THE EXTREME VALUE TYPE 1
C             DISTRIBUTION WITH MEAN = EULER'S NUMBER = 0.57721566
C             AND STANDARD DEVIATION = PI/SQRT(6) = 1.28254983.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 272-295.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--APRIL     1998. 
C     UPDATED         --JUNE      1999. USE SIMPLIFIED FORMULA FOR
C                                       MINIMUM CASE.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DX
CCCCC DOUBLE PRECISION DCDF
CCCCC DOUBLE PRECISION DPDF
      DOUBLE PRECISION DHAZ
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C     NO INPUT ARGUMENT ERRORS POSSIBLE 
C     FOR THIS DISTRIBUTION.
C
C-----START POINT-----------------------------------------------------
C
      IF(MINMAX.EQ.1)THEN
        IF(X.LE.REAL(I1MACH(15)))THEN
          HAZ=0.0
        ELSEIF(X.LE.REAL(I1MACH(16)))THEN
          HAZ=EXP(X)
        ELSE
          HAZ=0.0
          WRITE(ICOUT,1700)
          CALL DPWRST('XXX','BUG ')
        ENDIF
CCCCC   DX=DBLE(X)
CCCCC   CALL EV1CDD(DX,MINMAX,DCDF)
CCCCC   DCDF=1.0D0-DCDF
CCCCC   IF(DCDF.NE.0.0D0)THEN
CCCCC     DPDF=DEXP(DX-DEXP(DX))
CCCCC     DHAZ=DPDF/DCDF
CCCCC     HAZ=REAL(DHAZ)
CCCCC   ELSE
CCCCC     WRITE(ICOUT,1600)
C1600     FORMAT('*****ERROR IN EV1HAZ--CDF ESSENTIALLY 1.')
CCCCC     CALL DPWRST('XXX','BUG ')
CCCCC   ENDIF
      ELSEIF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
        DX=DBLE(-X)
CCCCC   DTERM1=DEXP(DX)-1.0D0
CCCCC   DHAZ=DEXP(DX-DTERM1)
        DTERM1=DEXP(DX)
        DTERM2=DEXP(DEXP(DX))-1.0D0
        IF(DTERM2.NE.0.0D0)THEN
          DHAZ=DTERM1/DTERM2
          HAZ=REAL(DHAZ)
        ELSE
          HAZ=0.0
          WRITE(ICOUT,1700)
 1700     FORMAT('*****ERROR IN EV1HAZ--UNABLE TO COMPUTE THE ',
     1          'HAZARD FUNCTION.')
          CALL DPWRST('XXX','BUG ')
        ENDIF
      ELSE
         HAZ=0.0
         WRITE(ICOUT,1800)
 1800    FORMAT('*****ERROR IN EV1HAZ--MINMAX NOT 1 OR 2')
         CALL DPWRST('XXX','BUG ')
      END IF
C
      RETURN
      END 
      SUBROUTINE EV1PDF(X,MINMAX,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE EXTREME VALUE TYPE 1
C              DISTRIBUTION.
C              THE EXTREME VALUE TYPE 1 DISTRIBUTION USED
C              HEREIN HAS MEAN = EULER'S NUMBER = 0.57721566
C              AND STANDARD DEVIATION = PI/SQRT(6) = 1.28254983.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              FOR THE MAXIMUM ORDER STATISTIC
C              F(X) = (EXP(-X)) * (EXP(-(EXP(-X))))
C              WHICH SIMPLIFIES TO:
C              F(X) = EXP(-X - EXP(-X))
C              FOR THE MINIMUIM ORDER STATISTIC
C              F(X) = (EXP(X)) * (EXP(-(EXP(X))))
C              WHICH SIMPLIFIES TO:
C              F(X) = EXP(-X - EXP(-X))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE CUMULATIVE DISTRIBUTION 
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE CDF FOR THE EXTREME VALUE TYPE 1
C             DISTRIBUTION WITH MEAN = EULER'S NUMBER = 0.57721566
C             AND STANDARD DEVIATION = PI/SQRT(6) = 1.28254983.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 272-295.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994. 
C     UPDATED         --JULY      2004. CODE IN DOUBLE PRECISION FOR
C                                       BETTER ACCURACY
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DPDF
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C     NO INPUT ARGUMENT ERRORS POSSIBLE 
C     FOR THIS DISTRIBUTION.
C
C-----START POINT-----------------------------------------------------
C
      DX=DBLE(X)
      IF(MINMAX.EQ.1)THEN
        DPDF=DEXP(DX-DEXP(DX)) 
      ELSEIF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
        DPDF=DEXP(-DX-DEXP(-DX)) 
      ELSE
         WRITE(ICOUT,1800)
 1800    FORMAT('*****ERROR IN EV1PDF--MINMAX NOT 1 OR 2')
         CALL DPWRST('XXX','BUG ')
      END IF
      PDF=REAL(DPDF)
C
      RETURN
      END 
      SUBROUTINE EV1PPF(P,MINMAX,PPF)
CCCCC MINMAX ADDED TO ABOVE ARGUMENT LIST   MAY 1993
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE EXTREME VALUE TYPE 1
C              (= GUMBEL)
C              DISTRIBUTION.
C              THERE ARE 2 SUCH EV1 FAMILIES--
C                 ONE FOR THE MIN ORDER STAT AND
C                 ONE FOR THE MAX ORDER STAT (THE USUAL).
C              (SEE SARHAN & GREENBERG, PAGE 69)
C              THE EV1 TYPE IS SPECIFIED VIA   MINMAX
C              FOR MINMAX = 1  (FOR THE MINIMUM)
C                 THE WEIBULL DISTRIBUTION USED
C                 HEREIN IS DEFINED FOR ALL X,
C                 AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X) = ...
C              FOR MINMAX = 2 (FOR THE DEFAULT MAXIMUM),
C                 THE EV1 DISTRIBUTION USED
C                 HEREIN IS DEFINED FOR ALL X,
C                 HAS MEAN = EULER'S NUMBER = 0.57721566
C                 HAS STANDARD DEVIATION = PI/SQRT(6) = 1.28254983.
C                 AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X) = (EXP(-X)) * (EXP(-(EXP(-X))))
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (EXCLUSIVELY)
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --MINMAX = THE INTEGER VALUE
C                                IDENTIFYING THE
C                                CHOSEN WEIBULL DISTRIBUTION.
C                                1 = MIN, 2 = MAX.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION .
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--SARHAN & GREENBERG,
C                 CONTRIBUTIONS TO ORDER STATISTICS,
C                 1962, WILEY, PAGE 69.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 272-295.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MAY       1993. REWRITTEN--ADD EV1/MIN DIST.
C     UPDATED         --JANUARY   1994. ADD MINMAX ERROR MESSAGE
C     UPDATED         --JULY      2004. CODE IN DOUBLE PRECISION
C                                       FOR BETTER ACCURACY.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DPPF
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
    1 FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT TO ',
     1'EV1PPF IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8)
C
CCCCC THE FOLLOWING LINE WAS REWRITTEN   MAY 1993
CCCCC PPF=(-(ALOG(-ALOG(P))))
C
CCCCC THE FOLLOWING SECTION WAS REWRITTEN      JANUARY 1994
      DP=DBLE(P)
      IF(MINMAX.EQ.1)THEN
         DPPF=DLOG(DLOG(1.0D0/(1.0D0-DP)))
      ELSE IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
         DPPF=(-(DLOG(DLOG(1.0D0/DP))))
      ELSE
         WRITE(ICOUT,1800)
 1800    FORMAT('*****ERROR IN EV1PPF--MINMAX NOT 1 OR 2')
         CALL DPWRST('XXX','BUG ')
      ENDIF
      PPF=REAL(DPPF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE EV1RAN(N,MINMAX,ISEED,X)
CCCCC MINMAX WAS ADDED TO THE ABOVE ARGUMENT LIST   MAY 1993
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE EXTREME VALUE TYPE 1 DISTRIBUTION.
C              THE PROTOTYPE EXTREME VALUE TYPE 1 DISTRIBUTION USED
C              HEREIN HAS MEAN = EULER'S NUMBER = 0.57721566
C              AND STANDARD DEVIATION = PI/SQRT(6) = 1.28254983.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (EXP(-X)) * (EXP(-(EXP(-X))))
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C                     --MINMAX = THE INTEGER VALUE
C                                IDENTIFYING THE
C                                CHOSEN WEIBULL DISTRIBUTION.
C                                1 = MIN, 2 = MAX.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE EXTREME VALUE TYPE 1 DISTRIBUTION
C             WITH MEAN = EULER'S NUMBER = 0.57721566
C             AND STANDARD DEVIATION = PI/SQRT(6) = 1.28254983.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--SARHAN & GREENBERG,
C                 CONTRIBUTIONS TO ORDER STATISTICS,
C                 1962, WILEY, PAGE 69.
C               --TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 14-15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 272-295.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MAY       1993. REWRITTEN--ADD EV1/MIN DIST.
C     UPDATED         --JANUARY   1994. ADD MINMAX ERROR MESSAGE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'EV1RAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N EXTREME VALUE TYPE 1 RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
CCCCC THE FOLLOWING SECTION WAS REWRITTEN   MAY 1993
CCCCC DO100I=1,N
CCCCC X(I)=-ALOG(ALOG(1.0/X(I)))
CC100 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS REWRITTEN      JANUARY 1994
      IF(MINMAX.EQ.1)THEN
         DO100I=1,N
         X(I)=ALOG(ALOG(1.0/(1.0-X(I))))
  100    CONTINUE
      ELSE IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
         DO200I=1,N
         X(I)=(-(ALOG(ALOG(1.0/X(I)))))
  200    CONTINUE
      ELSE
         WRITE(ICOUT,1800)
 1800    FORMAT('*****ERROR IN EV1RAN--MINMAX NOT 1 OR 2')
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE EV2CDF(X,GAMMA,MINMAX,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE EXTREME VALUE TYPE 2
C              DISTRIBUTION WITH SINGLE PRECISION 
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE EXTREME VALUE TYPE 2 DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              FOR THE MAXIMUM ORDER STATISTIC
C              F(X) = GAMMA * (X**(-GAMMA-1)) * EXP(-(X**(-GAMMA))).
C              FOR THE MINIMUM ORDER STATISTIC
C              F(X) = GAMMA * ((-X)**(-GAMMA-1)) * EXP(-((-X)**(-GAMMA))).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE CUMULATIVE DISTRIBUTION 
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = THE SINGLE PRECISION VALUE 
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE EXTREME VALUE TYPE 2
C             DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--GAMMA SHOULD BE POSITIVE.
C                 --X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 272-295.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 ICOUTINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,ICOUTINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0.AND.MINMAX.EQ.2)GOTO50
      IF(X.GT.0.0.AND.MINMAX.EQ.1)GOTO60
      IF(GAMMA.LE.0.0)GOTO55
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      WRITE(ICOUT,5)
      WRITE(ICOUT,46)X
      WRITE(ICOUT,47)MINMAX
      CDF=0.0
      RETURN
   55 CONTINUE
      WRITE(ICOUT,15) 
      WRITE(ICOUT,16) 
      WRITE(ICOUT,46)GAMMA
      CDF=0.0
      RETURN
   60 CONTINUE
      WRITE(ICOUT,4)
      WRITE(ICOUT,6)
      WRITE(ICOUT,46)X
      WRITE(ICOUT,47)MINMAX
      CDF=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT ')
    5 FORMAT('      TO THE EV2CDF SUBROUTINE IS NEGATIVE *****')
    6 FORMAT('      TO THE EV2CDF SUBROUTINE IS POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE')
   16 FORMAT('      EV2CDF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF MINMAX IS ',I5,' *****')
C
C-----START POINT-----------------------------------------------------
C
      IF(MINMAX.EQ.1)THEN
        CDF=1.0
        IF(X.GE.0.0)RETURN
        CDF=1.0-EXP(-(-X)**(-GAMMA)) 
      ELSEIF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
        CDF=0.0
        IF(X.LE.0.0)RETURN
        CDF=EXP(-(X**(-GAMMA))) 
      ELSE
         WRITE(ICOUT,1800)
 1800    FORMAT('*****ERROR IN EV2CDF--MINMAX NOT 1 OR 2')
         CALL DPWRST('XXX','BUG ')
      END IF
C
      RETURN
      END 
      SUBROUTINE EV2CDD(X,GAMMA,MINMAX,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE EXTREME VALUE TYPE 2
C              DISTRIBUTION WITH SINGLE PRECISION 
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE EXTREME VALUE TYPE 2 DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              FOR THE MAXIMUM ORDER STATISTIC
C              F(X) = GAMMA * (X**(-GAMMA-1)) * EXP(-(X**(-GAMMA))).
C              FOR THE MINIMUM ORDER STATISTIC
C              F(X) = GAMMA * ((-X)**(-GAMMA-1)) * EXP(-((-X)**(-GAMMA))).
C     NOTE--THIS IS A DOUBLE PRECISION VERSION OF EV2CDF USED IN
C           CALCULATING HAZARD FUNCTIONS
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE CUMULATIVE DISTRIBUTION 
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = THE SINGLE PRECISION VALUE 
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE EXTREME VALUE TYPE 2
C             DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--GAMMA SHOULD BE POSITIVE.
C                 --X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 272-295.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION X
      DOUBLE PRECISION GAMMA
      DOUBLE PRECISION CDF
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 ICOUTINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,ICOUTINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0D0.AND.MINMAX.EQ.2)GOTO50
      IF(X.GT.0.0D0.AND.MINMAX.EQ.1)GOTO60
      IF(GAMMA.LE.0.0D0)GOTO55
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      WRITE(ICOUT,5)
      WRITE(ICOUT,46)X
      WRITE(ICOUT,47)MINMAX
      CDF=0.0
      RETURN
   55 CONTINUE
      WRITE(ICOUT,15) 
      WRITE(ICOUT,16) 
      WRITE(ICOUT,46)GAMMA
      CDF=0.0
      RETURN
   60 CONTINUE
      WRITE(ICOUT,4)
      WRITE(ICOUT,6)
      WRITE(ICOUT,46)X
      WRITE(ICOUT,47)MINMAX
      CDF=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT ')
    5 FORMAT('      TO THE EV2CDF SUBROUTINE IS NEGATIVE *****')
    6 FORMAT('      TO THE EV2CDF SUBROUTINE IS POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE')
   16 FORMAT('      EV2CDF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF MINMAX IS ',I5,' *****')
C
C-----START POINT-----------------------------------------------------
C
      IF(MINMAX.EQ.1)THEN
        CDF=1.0D0
        IF(X.GE.0.0D0)RETURN
        CDF=1.0D0-DEXP(-(-X)**(-GAMMA)) 
      ELSEIF(MINMAX.EQ.2 .OR. MINMAX.EQ.2)THEN
        CDF=0.0D0
        IF(X.LE.0.0D0)RETURN
        CDF=DEXP(-(X**(-GAMMA))) 
      ELSE
         WRITE(ICOUT,1800)
 1800    FORMAT('*****ERROR IN EV2CDF--MINMAX NOT 1 OR 2')
         CALL DPWRST('XXX','BUG ')
      END IF
C
      RETURN
      END
      SUBROUTINE EV2CHA(X,GAMMA,MINMAX,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE EXTREME VALUE TYPE 2
C              DISTRIBUTION WITH SINGLE PRECISION 
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE EXTREME VALUE TYPE 2 DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              FOR THE MAXIMUM ORDER STATISTIC
C              F(X) = GAMMA * (X**(-GAMMA-1)) * EXP(-(X**(-GAMMA))).
C              FOR THE MINIMUM ORDER STATISTIC
C              F(X) = GAMMA * ((-X)**(-GAMMA-1)) * EXP(-((-X)**(-GAMMA))).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = THE SINGLE PRECISION VALUE 
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION CUMULATIVE HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD
C             FUNCTION VALUE HAZ FOR THE EXTREME VALUE TYPE 2
C             DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--GAMMA SHOULD BE POSITIVE.
C                 --X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 272-295.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1998. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION CDF
      DOUBLE PRECISION DHAZ
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 ICOUTINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,ICOUTINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0.AND.MINMAX.EQ.2)GOTO50
      IF(X.GT.0.0.AND.MINMAX.EQ.1)GOTO60
      IF(GAMMA.LE.0.0)GOTO55
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      WRITE(ICOUT,5)
      WRITE(ICOUT,46)X
      WRITE(ICOUT,47)MINMAX
      HAZ=0.0
      RETURN
   55 CONTINUE
      WRITE(ICOUT,15) 
      WRITE(ICOUT,16) 
      WRITE(ICOUT,46)GAMMA
      HAZ=0.0
      RETURN
   60 CONTINUE
      WRITE(ICOUT,4)
      WRITE(ICOUT,6)
      WRITE(ICOUT,47)MINMAX
      WRITE(ICOUT,46)X
      WRITE(ICOUT,47)MINMAX
      HAZ=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT ')
    5 FORMAT('      TO THE EV2CHA SUBROUTINE IS NEGATIVE *****')
    6 FORMAT('      TO THE EV2CHA SUBROUTINE IS POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE')
   16 FORMAT('      EV2CHA SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF MINMAX IS ',I5,' *****')
C
C-----START POINT-----------------------------------------------------
C
      IF(MINMAX.EQ.1)THEN
        DGAMMA=DBLE(GAMMA)
        DX=DBLE(X)
        DHAZ=(-DX)**(-DGAMMA)
        HAZ=REAL(DHAZ)
      ELSEIF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
        CALL EV2CDD(DBLE(X),DBLE(GAMMA),MINMAX,CDF)
        CDF=1.0D0-CDF
        IF(CDF.LE.0.0D0)THEN
          WRITE(ICOUT,1100)
          CALL DPWRST('XXX','BUG ')
 1100     FORMAT('*****ERROR IN EV2CHA--CDF ESSENTIALLY 1.')
        ELSE
          DHAZ=-DLOG(CDF)
          HAZ=REAL(DHAZ)
        ENDIF
      ELSE
         WRITE(ICOUT,1800)
 1800    FORMAT('*****ERROR IN EV2CHA--MINMAX NOT 1 OR 2')
         CALL DPWRST('XXX','BUG ')
      END IF
C
      RETURN
      END 
      DOUBLE PRECISION FUNCTION EV2FUN (GHAT,X)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE MAXIMUM LIKELIHOOD
C              ESTIMATE OF GAMMA FOR THE 2-PARAMETER FRECHET
C              (EXTREME VALUE TYPE 2)
C              MODEL FOR FULL SAMPLE DATA (NO CENSORING).  THIS
C              FUNCTION FINDS THE ROOT OF THE EQUATION:
C
C                 (1/GHAT) +
C                 SUM[i=1 to n][Y(I)**(-GHAT)*LN(Y(I))]/
C                 SUM[i=1 to n][[Y(I)**(-GHAT)] -
C                 (1/N)*SUM[i=1 to n][LN(Y(I))] = 0
C
C              WITH
C
C                 GHAT     = POINT ESTIMATE OF GAMMA (THIS IS THE
C                            PARAMETER WE ARE ITERATING OVER)
C
C              NOTE THAT THE THIRD TERM DOES NOT DEPEND ON GHAT,
C              SO THIS IS A CONSTANT.  FOR EFFICIENCY, SAVE THIS AS
C              A CONSTANT IN A COMMON BLOCK.
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.
C     EXAMPLE--FRECHET MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 16.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2005/5
C     ORIGINAL VERSION--MAY        2005.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION GHAT
      DOUBLE PRECISION X(*)
C
      INTEGER IN 
      DOUBLE PRECISION DEV2SM
      COMMON/EV2COM/DEV2SM,IN
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DX1
      DOUBLE PRECISION DG
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DG=GHAT
C
      DTERM1=1.0D0/DG
      DO100I=1,IN
        DX1=X(I)
        DSUM1=DSUM1 + (DX1**(-DG))*DLOG(DX1)
        DSUM2=DSUM2 + DX1**(-DG)
  100 CONTINUE
      DTERM2=DSUM1/DSUM2
C
      EV2FUN=DTERM1 + DTERM2 - DEV2SM
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION EV2FU2 (DA,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDECE INTERVAL FOR THE 2-PARAMETER FRECHET
C              MODEL (FULL SAMPLE).  THIS FUNCTION FINDS THE ROOT
C              OF THE EQUATION:
C
C                 2*LL(ALPHA,GAMMA) - 2*LL(S(a),,a) - CHSPPF(alpha,1)
C
C              WITH
C
C                 LL(ALPHA,GAMMA) = N*LN(GAMMA) + N*GAMMA*LN(ALPHA) -
C                          (GAMMA+1)*SUM[i=1 to n][LN(X(i))] -
C                          ALPHA**GAMMA*SUM[i=1 to n][(X(i)**(-GAMA)]
C                 ALPHA    = POINT ESTIMATE OF SCALE PARAMETER
C                 GAMMA    = POINT ESTIMATE OF SHAPE PARAMETER
C                 A        = PARAMETER WE ARE FINDING ROOT FOR
C                 K        = CHSPPF(ALPHA,1) (HERE, ALPHA IS THE
C                            SIGNIFICANCE LEVEL, NOT THE SCALE PARAMETER)
C
C              NOTE THAT QUANTITIES THAT DO NOT DEPEND ON A ARE
C              COMPUTED ONCE IN DPMLFR AND PASSED VIA COMMON BLOCK.
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.  DFZER2 IS MODIFIED VERSION OF DFZERO THAT
C              PASSES ALONG THE DATA ARRAY.
C
C     EXAMPLE--FRECHET MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 16 (SEE
C                EXAMPLE 16.4).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2005/5
C     ORIGINAL VERSION--MAY        2005.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DA
      DOUBLE PRECISION DX(*)
C
      DOUBLE PRECISION DK
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      COMMON/EV2CO2/DK,DTERM1,DTERM2,N
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DG
      DOUBLE PRECISION DSCALE
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      DN=DBLE(N)
      DG=DA
C
      DSUM1=0.0D0
      DO100I=1,N
        DSUM1=DSUM1 + DX(I)**(-DG)
  100 CONTINUE
      DSCALE=(DSUM1/DN)**(-1.0D0/DG)
C
      DTERM3=DN*DLOG(DG) + DN*DG*DLOG(DSCALE)
      DTERM4=(DG+1.0D0)*DTERM2
      DTERM5=DSCALE**DG*DSUM1
C
      EV2FU2=DTERM1 - 2.0D0*(DTERM3 - DTERM4 - DTERM5) - DK
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION EV2FU3 (DB,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR THE SCALE PARAMETER OF A
C              2-PARAMETER FRECHET MODEL (FULL SAMPLE).  THIS
C              FUNCTION FINDS THE ROOT OF THE EQUATION:
C
C                 2*LL(ALPHA,GAMMA) - 2*LL(b,I(b)) - CHSPPF(alpha,1)
C
C              WITH
C
C                 LL(ALPHA,GAMMA) = N*LN(GAMMA) + N*GAMMA*LN(ALPHA) -
C                          (GAMMA+1)*SUM[i=1 to n][LN(X(i))] -
C                          ALPHA**GAMMA*SUM[i=1 to n][(X(i)**(-GAMMA)]
C                 ALPHA    = POINT ESTIMATE OF SCALE PARAMETER
C                 GAMMA    = POINT ESTIMATE OF SHAPE PARAMETER
C                 B        = PARAMETER (SCALE) WE ARE FINDING ROOT FOR
C                 K        = CHSPPF(ALPHA,1) (HERE, ALPHA IS THE
C                            SIGNIFICANCE LEVEL, NOT THE SCALE
C                            PARAMETER)
C
C              NOTE THAT QUANTITIES THAT DO NOT DEPEND ON B ARE
C              COMPUTED ONCE IN DPMLFR AND PASSED VIA COMMON BLOCK.
C
C              GIVEN A VALUE FOR THE SCALE PARAMETER (DB), WE NEED
C              TO CALL A ROOT FINDING ROUTINE TO DETERMINE THE VALUE
C              OF THE SHAPE PARAMETER (A).
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.  DFZER2 IS MODIFIED VERSION OF DFZERO THAT
C              PASSES ALONG THE DATA ARRAY.
C
C     EXAMPLE--FRECHET MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 16 (SEE
C                EXAMPLE 16.4).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2005/5
C     ORIGINAL VERSION--MAY        2005.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DB
      DOUBLE PRECISION DX(*)
C
      DOUBLE PRECISION DK
      DOUBLE PRECISION DTERM6
      DOUBLE PRECISION DTERM7
      DOUBLE PRECISION DGAMMA
      COMMON/EV2CO3/DK,DTERM6,DTERM7,DGAMMA,N
C
      DOUBLE PRECISION DBTEMP
      COMMON/EV2CO4/DBTEMP,N2
C
      DOUBLE PRECISION AE
      DOUBLE PRECISION RE
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XSTRT
      DOUBLE PRECISION DA
      DOUBLE PRECISION DG
      DOUBLE PRECISION DN
      DOUBLE PRECISION DSCALE
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
C
      DOUBLE PRECISION EV2FU4
      EXTERNAL EV2FU4
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  STEP 1: GIVEN VALUE OF SCALE PARAMETER (DB), NEED TO COMPUTE
C          THE SHAPE PARAMETER (WHICH IN TURN INVOLVES FINDING A
C          ROOT).

      N2=N
      DBTEMP=DB
      AE=1.D-7
      RE=1.D-7
      XSTRT=DGAMMA
      XLOW=XSTRT/5.0D0
      XUP=XSTRT*5.0D0
      CALL DFZER3(EV2FU4,XLOW,XUP,XSTRT,RE,AE,IFLAG,DX)
      DA=XLOW
C
C  COMPUTE SOME SUMS
C
      DN=DBLE(N)
      DG=DA
      DSCALE=DB
C
      DSUM1=0.0D0
      DO100I=1,N
        DSUM1=DSUM1 + DX(I)**(-DG)
  100 CONTINUE
C
      DTERM3=DN*DLOG(DG) + DN*DG*DLOG(DSCALE)
      DTERM4=(DG+1.0D0)*DTERM7
      DTERM5=DSCALE**DG*DSUM1
C
      EV2FU3=DTERM6 - 2.0D0*(DTERM3 - DTERM4 - DTERM5) - DK
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION EV2FU4 (DA,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR THE SCALE PARAMETER OF
C              THE 2-PARAMETER FRECHET MODEL (FULL SAMPLE).
C              SPECIFICALLY, IT IS USED TO DETERMINE AN ESTIMATE
C              OF THE SHAPE PARAMETER GIVEN A VALUE OF THE SCALE
C              PARAMETER.  IT FINDS THE ROOT OF THE FOLLOWING
C              EQUATION:
C
C                 (N/A) + N*LOG(B) - SUM[LOG(X)] -
C                       SUM[(B/X)**A*LOG(B/X)]
C
C              WITH A DENOTING THE SHAPE PARAMETER, B THE SCALE
C              PARAMETER, AND THE ROOT IS WITH RESPECT TO A.
C
C              CALLED BY DFZER3 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.  DFZER3 IS MODIFIED VERSION OF DFZERO THAT
C              PASSES ALONG THE DATA ARRAY.
C
C     EXAMPLE--FRECHET MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 16 (SEE
C                EXAMPLE 16.4).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2005/5
C     ORIGINAL VERSION--MAY        2005.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DA
      DOUBLE PRECISION DX(*)
C
      DOUBLE PRECISION DB
      COMMON/EV2CO4/DB,N
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      DN=DBLE(N)
      DTERM1=(DN/DA) + DN*DLOG(DB)
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO100I=1,N
        DSUM1=DSUM1 + DLOG(DX(I))
        DSUM2=DSUM2 + ((DB/DX(I))**DA)*DLOG(DB/DX(I))
  100 CONTINUE
C
      EV2FU4=DTERM1 - DSUM1 - DSUM2
C
      RETURN
      END
      SUBROUTINE EV2HAZ(X,GAMMA,MINMAX,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE EXTREME VALUE TYPE 2
C              DISTRIBUTION WITH SINGLE PRECISION 
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE EXTREME VALUE TYPE 2 DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              FOR THE MAXIMUM ORDER STATISTIC
C              F(X) = GAMMA * (X**(-GAMMA-1)) * EXP(-(X**(-GAMMA))).
C              FOR THE MINIMUM ORDER STATISTIC
C              F(X) = GAMMA * ((-X)**(-GAMMA-1)) * EXP(-((-X)**(-GAMMA))).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = THE SINGLE PRECISION VALUE 
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION HAZARD
C             FUNCTION VALUE HAZ FOR THE EXTREME VALUE TYPE 2
C             DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--GAMMA SHOULD BE POSITIVE.
C                 --X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 272-295.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1998. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION CDF
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 ICOUTINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,ICOUTINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0.AND.MINMAX.EQ.2)GOTO50
      IF(X.GT.0.0.AND.MINMAX.EQ.1)GOTO60
      IF(GAMMA.LE.0.0)GOTO55
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      WRITE(ICOUT,5)
      WRITE(ICOUT,46)X
      WRITE(ICOUT,47)MINMAX
      HAZ=0.0
      RETURN
   55 CONTINUE
      WRITE(ICOUT,15) 
      WRITE(ICOUT,16) 
      WRITE(ICOUT,46)GAMMA
      HAZ=0.0
      RETURN
   60 CONTINUE
      WRITE(ICOUT,4)
      WRITE(ICOUT,6)
      WRITE(ICOUT,47)MINMAX
      WRITE(ICOUT,46)X
      WRITE(ICOUT,47)MINMAX
      HAZ=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT ')
    5 FORMAT('      TO THE EV2HAZ SUBROUTINE IS NEGATIVE *****')
    6 FORMAT('      TO THE EV2HAZ SUBROUTINE IS POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE')
   16 FORMAT('      EV2HAZ SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF MINMAX IS ',I5,' *****')
C
C-----START POINT-----------------------------------------------------
C
      DGAMMA=DBLE(GAMMA)
      DX=DBLE(X)
      IF(MINMAX.EQ.1)THEN
        DHAZ=DGAMMA*(-DX)**(-DGAMMA-1.0D0)
        HAZ=REAL(DHAZ)
      ELSEIF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
        DPDF=DGAMMA*(DX**(-DGAMMA-1.0))*DEXP(-(DX**(-DGAMMA))) 
        CALL EV2CDD(DBLE(X),DBLE(GAMMA),MINMAX,CDF)
        IF(1.0D0-CDF.LE.0.0D0)THEN
          WRITE(ICOUT,1100)
          CALL DPWRST('XXX','BUG ')
 1100     FORMAT('*****ERROR IN EV2HAZ--CDF ESSENTIALLY 1, ',
     1           'HAZARD SET TO 0.')
        ELSE
          HAZ=REAL(DPDF/(1.0D0-CDF))
        ENDIF
      ELSE
         WRITE(ICOUT,1800)
 1800    FORMAT('*****ERROR IN EV2HAZ--MINMAX NOT 1 OR 2')
         CALL DPWRST('XXX','BUG ')
      END IF
C
      RETURN
      END 
      SUBROUTINE EV2PDF(X,GAMMA,MINMAX,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE EXTREME VALUE TYPE 2
C              DISTRIBUTION WITH SINGLE PRECISION 
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE EXTREME VALUE TYPE 2 DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              FOR THE MAXIMUM ORDER STATISTIC
C              F(X) = GAMMA * (X**(-GAMMA-1)) * EXP(-(X**(-GAMMA))).
C              FOR THE MINIMUM ORDER STATISTIC
C              F(X) = GAMMA * ((-X)**(-GAMMA-1)) * EXP(-((-X)**(-GAMMA))).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = THE SINGLE PRECISION VALUE 
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE EXTREME VALUE TYPE 2
C             DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--GAMMA SHOULD BE POSITIVE.
C                 --X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 272-295.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1994. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 ICOUTINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,ICOUTINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0.AND.MINMAX.EQ.2)GOTO50
      IF(X.GT.0.0.AND.MINMAX.EQ.1)GOTO60
      IF(GAMMA.LE.0.0)GOTO55
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      WRITE(ICOUT,5)
      WRITE(ICOUT,46)X
      WRITE(ICOUT,47)MINMAX
      PDF=0.0
      RETURN
   55 CONTINUE
      WRITE(ICOUT,15) 
      WRITE(ICOUT,16) 
      WRITE(ICOUT,46)GAMMA
      PDF=0.0
      RETURN
   60 CONTINUE
      WRITE(ICOUT,4)
      WRITE(ICOUT,6)
      WRITE(ICOUT,47)MINMAX
      WRITE(ICOUT,46)X
      WRITE(ICOUT,47)MINMAX
      PDF=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT ')
    5 FORMAT('      TO THE EV2PDF SUBROUTINE IS NEGATIVE *****')
    6 FORMAT('      TO THE EV2PDF SUBROUTINE IS POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE')
   16 FORMAT('      EV2PDF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF MINMAX IS ',I5,' *****')
C
C-----START POINT-----------------------------------------------------
C
      IF(MINMAX.EQ.1)THEN
        PDF=GAMMA*((-X)**(-GAMMA-1.0))*EXP(-((-X)**(-GAMMA))) 
      ELSEIF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
        PDF=GAMMA*(X**(-GAMMA-1.0))*EXP(-(X**(-GAMMA))) 
      ELSE
         WRITE(ICOUT,1800)
 1800    FORMAT('*****ERROR IN EV2PDF--MINMAX NOT 1 OR 2')
         CALL DPWRST('XXX','BUG ')
      END IF
C
      RETURN
      END 
      SUBROUTINE EV2PPF(P,GAMMA,MINMAX,PPF)
CCCCC MINMAX ADDED TO ABOVE ARGUMENT LIST   MAY 1993
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE EXTREME VALUE TYPE 2
C              (= FRECHET)
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THERE ARE 2 SUCH EV2 FAMILIES--
C                 ONE FOR THE MIN ORDER STAT (THE USUAL) AND
C                 ONE FOR THE MAX ORDER STAT.
C              (SEE SARHAN & GREENBERG, PAGE 69)
C              THE EV2 TYPE IS SPECIFIED VIA   MINMAX
C              FOR MINMAX = 1  (FOR THE MINIMUM)
C                 THE EV2 DISTRIBUTION USED
C                 HEREIN IS DEFINED FOR ALL NEGATIVE X,
C                 AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X) = ...
C              FOR MINMAX = 2 (FOR THE DEFAULT MAXIMUM),
C                 THE EV2 DISTRIBUTION USED
C                 HEREIN IS DEFINED FOR ALL POSITIVE X,
C                 AND HAS THE PROBABILITY DENSITY FUNCTION
C               F(X) = GAMMA * (X**(-GAMMA-1)) * EXP(-(X**(-GAMMA))).
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (EXCLUSIVELY)
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C                     --MINMAX = THE INTEGER VALUE
C                                IDENTIFYING THE
C                                CHOSEN WEIBULL DISTRIBUTION.
C                                1 = MIN, 2 = MAX.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION .
C             VALUE PPF FOR THE EXTREME VALUE TYPE 2 DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--GAMMA SHOULD BE POSITIVE.
C                 --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--SARHAN & GREENBERG,
C                 CONTRIBUTIONS TO ORDER STATISTICS,
C                 1962, WILEY, PAGE 69.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 272-295.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MAY       1993. REWRITTEN--ADD EV2/MAX DIST.
C     UPDATED         --JANUARY   1994. ADD MINMAX ERROR MESSAGE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0.OR.P.GE.1.0)GOTO50
      IF(GAMMA.LE.0.0)GOTO55
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   55 WRITE(ICOUT,15)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)GAMMA
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'EV2PPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'EV2PPF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
CCCCC THE FOLLOWING LINE WAS REWRITTEN    MAY 1993
CCCCC PPF=(-ALOG(P))**(-1.0/GAMMA)
C
CCCCC THE FOLLOWING SECTION WAS REWRITTEN      JANUARY 1994
      IF(MINMAX.EQ.1)THEN
         PPF= (-(ALOG(1.0/(1.0-P)))**(-1.0/GAMMA))
      ELSE IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
         PPF= (ALOG(1.0/P))**(-1.0/GAMMA)
      ELSE
         WRITE(ICOUT,1800)
 1800    FORMAT('*****ERROR IN EV2PPF--MINMAX NOT 1 OR 2')
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE EV2RAN(N,GAMMA,MINMAX,ISEED,X)
CCCCC MINMAX WAS ADDED TO THE ABOVE ARGUMENT LIST   MAY 1993
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE EXTREME VALUE TYPE 2 DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C              THE PROTOTYPE EXTREME VALUE TYPE 2 DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = GAMMA * (X**(-GAMMA-1)) * EXP(-(X**(-GAMMA))).
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE OF THE
C                                TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C                     --MINMAX = THE INTEGER VALUE
C                                IDENTIFYING THE
C                                CHOSEN WEIBULL DISTRIBUTION.
C                                1 = MIN, 2 = MAX.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE EXTREME VALUE TYPE 2 DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--SARHAN & GREENBERG,
C                 CONTRIBUTIONS TO ORDER STATISTICS,
C                 1962, WILEY, PAGE 69.
C               --TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 14-15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 272-295.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MAY       1993. MINMAX
C     UPDATED         --JANUARY   1994. ADD MINMAX ERROR MESSAGE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      IF(GAMMA.LE.0.0)GOTO60
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   60 WRITE(ICOUT,15)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)GAMMA
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'EV2RAN SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'EV2RAN SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N EXTREME VALUE TYPE 2 DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
CCCCC THE FOLLOWING SECTION WAS REWRITTEN    MAY 1993
CCCCC DO100I=1,N
CCCCC X(I)=(-ALOG(X(I)))**(-1.0/GAMMA)
CC100 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS REWRITTEN      JANUARY 1994
      IF(MINMAX.EQ.1)THEN
         DO100I=1,N
         X(I)= (-(ALOG(1.0/(1.0-X(I))))**(-1.0/GAMMA))
  100    CONTINUE
      ELSE IF(MINMAX.EQ.2 .OR. MINMAX.EQ.0)THEN
         DO200I=1,N
         X(I)= (ALOG(1.0/X(I)))**(-1.0/GAMMA)
  200    CONTINUE
      ELSE
         WRITE(ICOUT,1800)
 1800    FORMAT('*****ERROR IN EV2RAN--MINMAX NOT 1 OR 2')
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE EVALM(IW2,IW22,W2,ITYPE,ISTART,ISTOP,IANGLU,ANS,
CCCCC FOLLOWING LINE MODIFIED  SEPTEMBER 1994.
CCCCC1SAVE1,SAVE2,SAVE3,IBUGEV,IERROR)
CCCCC FOLLOWING LINE MODIFIED  APRIL 1995
CCCCC1SAVE1,SAVE2,SAVE3,SAVE4,ILIBC1,ILIBC2,IBUGEV,IERROR)
CCCCC FOLLOWING LINE MODIFIED  MAY 1998
     1SAVE1,SAVE2,SAVE3,SAVE4,SAVE5,SAVE6,SAVE7,SAVE8,
     1ILIBC1,ILIBC2,IBUGEV,IERROR)
C
C     PURPOSE--EVALUATE A STRING OF CODE THAT CONTAINS ONLY
C     VALUES, OPERATIONS, AND LIBRARY FUNCTIONS.
C     NOTE--THE DECEMBER UPDATE AUGMENTED THE
C           USUAL MATH LIBRARY WITH
C           ARCSIN, ARCCOS, ARCTAN, OCTAL
C     NOTE--THE UPDATE WHICH ALLOWS 2 ARGUMENTS AND 3 ARGUMENTS
C           AS IN TCDF, CHSCDF, FCDF, ETC. HAS THE FOLLOWING RESTRICTIONS--
C           1) NO EXPRESSIONS FOR ARGUMENTS (MAYBE FOR FIRST)
C           2) NO NEGATIVE ARGUMENTS FOR SECOND AND THIRD ARGUMENTS
C           (FORTUNATELY THIS LAST RESTRICTION IS NO RESTRICTION
C           AT ALL FOR THE T, CHI-SQUARED, AND F DISTRIBUTIONS
C           BECAUSE THEY REQUIRE POSITIVE DEGREES OF FREEDOM ANYWAY.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER 1, 1976.
C     UPDATED--DECEMBER 21, 1977.
C     UPDATED--DECEMBER 28, 1977.
C     UPDATED         --JULY      1978.
C     UPDATED         --JULY      1978.
C     UPDATED         --OCTOBER   1978.
C     UPDATED         --JANUARY   1979.
C     UPDATED         --FEBRUARY  1979.
C     UPDATED         --JUNE      1979.
C     UPDATED         --JULY      1979.
C     UPDATED         --FEBRUARY  1981.
C     UPDATED         --JUNE      1981.
C     UPDATED         --JULY      1981.
C     UPDATED         --SEPTEMBER 1981.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MARCH     1989.  SAVE3 ARGUMENT (FOR JULIA SETS)
C     UPDATED         --JUNE      1989.  UNDERFLOW SET TO 0 FOR * AND /
C     UPDATED         --MAY       1994.  SET SAVE2 AND SAVE3 TO -99.9
C                                        TO AVOID FCDF ERROR WITH
C                                        TOO FEW ARGUMENTS.
C     UPDATED         --SEPTEMBER 1994.  ADD SAVE4 ARGUMENT FOR DNFCDF
C     UPDATED         --APRIL     1995.  INITIALIZE SAVE1 ... SAVE4
C                                        (BUG IN HEAVE FUNCTION, WHERE
C                                        ARGUMENTS OPTIONAL)
C                                        ALSO, BUG IN FOLLOWING
C                                        LET A = TPDF(X,2) - TPDF(X,3)
C                                        BOTH USE 2 FOR SECOND ARG.
C     UPDATED         --SEPTEMBER 1997.  WORKAROUND FOR "**" OPERATION
C                                        (BUG IN OLD LAHEY COMPILER)
C     UPDATED         --MAY       1998.  ADD SAVE5
C     UPDATED         --NOVEMBER  1998.  FIX FOR 0**(POSITIVE NUMB)
C     UPDATED         --JUNE      2003.  ADD SAVE6, SAVE7, SAVE8
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IW2
      CHARACTER*4 IW22
      CHARACTER*4 ITYPE
      CHARACTER*4 IANGLU
      CHARACTER*4 IBUGEV
      CHARACTER*4 IERROR
C
      CHARACTER*4 IOP
C
C---------------------------------------------------------------------
C
      DIMENSION IW2(*)
      DIMENSION IW22(*)
      DIMENSION W2(*)
      DIMENSION ITYPE(*)
      DIMENSION TERM(80)
      DIMENSION IOP(80)
C
CCCCC FOLLOWING SECTION ADDED APRIL 1995.
      DIMENSION SAVE1(*)
      DIMENSION SAVE2(*)
      DIMENSION SAVE3(*)
      DIMENSION SAVE4(*)
      DIMENSION SAVE5(*)
      DIMENSION SAVE6(*)
      DIMENSION SAVE7(*)
      DIMENSION SAVE8(*)
C
CCCCC FOLLOWING LINE FOR LAHEY BUG.  SEPTEMBER 1997.
      INCLUDE 'DPCOHO.INC'
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C     DEFINE THE UPPER LIMIT OF THE NUMBER OF 'TERMS'
C     THAT THIS SUBROUTINE CAN PROCESS.
C     THIS IS USUALLY THE SAME AS THE MAX NUMBER OF CHARACTERS
C     THAT MAY BE PROCESSED BY THE COMPIM SUBROUTINE
C     IF RESTRICT THE FUNCTIONAL EXPRESSION TO 1 LINE IMAGE,
C     THEN A REASONABLE UPPER BOUND IS 80.
C     WHATEVER UPPER BOUND IS SET,
C     THE DIMENSIONS OF THE VECTORS
C     TERM(.) AND IOP(.),  USED HEREIN
C     MUST BE EQUAL OR LARGER TO THIS NUMBER.
C
      DATA MAXTER/80/
C
C-----START POINT-----------------------------------------------------
C
      ANS=0.0
      IERROR='NO'
C
      CUTOFF=0.00001
C
      AIABS2=(-999.0)
C
      ALCPUM=ALOG(CPUMAX)
C
C     CHECK THAT THE INPUT PARAMETERS ISTART AND ISTOP)
C     ARE BOTH AT LEAST 1 AND BOTH AT MOST MAXTER
C     (WHERE MAXTER IS THE INTERNALLY DEFINED VARIABLE
C     WHICH CONTROLS DIMENSION SIZES AND WHICH
C     TYPICALLY HAS THE VALUE 80).
C     ALSO CHECK THAT ISTART DOES NOT EXCEED ISTOP.
C
      IF(ISTART.LT.1.OR.MAXTER.LT.ISTART)GOTO20
      IF(ISTOP.LT.1.OR.MAXTER.LT.ISTOP)GOTO20
      IF(ISTOP.LT.ISTART)GOTO20
      GOTO39
   20 CONTINUE
      WRITE(ICOUT,21)
   21 FORMAT('***** ERROR IN EVALM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,22)
   22 FORMAT('      ILLEGAL VALUES FOR THE INPUT PARAMETERS ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,23)
   23 FORMAT('      ISTART AND/OR ISTOP.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,24)
   24 FORMAT('      BOTH ISTART AND ISTOP MUST BE AT LEAST 1')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,25)
   25 FORMAT('      AND AT MOST MAXTER')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,26)
   26 FORMAT('      (WHERE MAXTER IS AN INTERNALLY-DEFINED',
     1'VARIABLE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,27)MAXTER
   27 FORMAT('      WHICH HAS THE VALUE = ',I8,'   .')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,28)
   28 FORMAT('      ALSO, ISTART MUST BE SMALLER THAN')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,29)
   29 FORMAT('      OR AT MOST EQUAL TO ISTOP')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,30)ISTART
   30 FORMAT('      ISTART = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,31)ISTOP
   31 FORMAT('      ISTOP  = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,32)MAXTER
   32 FORMAT('      MAXTER = ',I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
   39 CONTINUE
C
      IF(IBUGEV.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF EVALM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ISTART,ISTOP
   52 FORMAT('ISTART,ISTOP = ',2I6)
      CALL DPWRST('XXX','BUG ')
      DO53I=ISTART,ISTOP
      WRITE(ICOUT,54)I,IW2(I),IW22(I),W2(I),ITYPE(I)
   54 FORMAT('I,IW2(I),IW22(I),W2(I),ITYPE(I) = ',I8,2X,A4,2X,A4,
     1F15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
   53 CONTINUE
      WRITE(ICOUT,56)IBUGEV
   56 FORMAT('IBUGEV = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,57)IANGLU
   57 FORMAT('IANGLU = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,58)SAVE1(1),SAVE2(1),SAVE3(1),SAVE4(1)
   58 FORMAT('I=1,SAVE1,SAVE2,SAVE3,SAVE4 = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C     BLANK-OUT THE IOP(.) VECTOR AND ZERO-OUT THE TERM(.) VECTOR.
C
      DO110I=1,MAXTER
      TERM(I)=0.0
      IOP(I)='    '
  110 CONTINUE
C
C               ***************************************************************
C               **  STEP 1--                                                 **
C               **  OPERATE ON THE VECTORS IW2(.) AND IW22(.).               **
C               **  THEY SHOULD CONTAIN NO PARENTHESES.                      **
C               **  THEY SHOULD CONTAIN ONLY--                               **
C               **       NUMBERS                                             **
C               **       X VALUES                                            **
C               **       PARAMETER VALUES                                    **
C               **       PREVIOUSLY COMPUTED VALUES                          **
C               **       OPERATIONS (5--+ - * / **)                          **
C               **       LIBRARY FUNCTIONS.                                  **
C               **  COPY THE NUMBERS, X VALUES, PARAMETER VALUES,            **
C               **  AND PREVIOUSLY COMPUTED VALUES OVER TO THE TERM VECTOR.  **
C               **  COPY THE OPERATIONS OVER TO THE OPERATIONS VECTOR.       **
C               **  ELIMINATE THE LIBRARY FUNCTIONS BY EVALUATING THEM       **
C               **  WITH THE NEXT POTENTIAL TERM AND PUTTING                 **
C               **  THE EVALUATED RESULT INTO THAT NEXT TERM.                **
C               **  OUTPUT THE VECTOR TERMS(.) AND THE VECTOR IOP(.)
C               **  WHICH CONTAIN TERMS AND OPERATIONS RESPECTIVELY.         **
C               ***************************************************************
C
      IF(ITYPE(ISTOP).EQ.'OP')GOTO120
      IF(ITYPE(ISTOP).EQ.'LF')GOTO122
      GOTO130
  120 CONTINUE
      WRITE(ICOUT,121)ITYPE(ISTOP)
  121 FORMAT('***** ERROR IN EVALM--LAST TERM ',
     1'IN AN INTERMEDIATE EXPRESSION = AN OPERATION = ',A4)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  122 CONTINUE
      WRITE(ICOUT,123)ITYPE(ISTOP)
  123 FORMAT('***** ERROR IN EVALM--LAST TERM ',
     1'IN AN INTERMEDIATE EXPRESSION = A LIBRARY FUNCTION = ',A4)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  130 CONTINUE
C
CCCCC APRIL 1995.  ADD FOLLOWING LINE.
CCCCC ILIBC1=ILIBC1+1
C
      NOP=0
      NTERM=0
      NUMSAV=0
      I=ISTART
C
  150 CONTINUE
      IDEL=1
      IP1=I+1
      IP2=I+2
      IP3=I+3
      IP4=I+4
      IP5=I+5
      IF(ITYPE(I).EQ.'N')GOTO200
      IF(ITYPE(I).EQ.'X')GOTO200
      IF(ITYPE(I).EQ.'PAR')GOTO200
      IF(ITYPE(I).EQ.'V')GOTO200
      IF(ITYPE(I).EQ.'OP')GOTO300
      IF(ITYPE(I).EQ.'LF'.AND.ITYPE(IP1).EQ.'V')GOTO400
      IF(ITYPE(I).EQ.'LF'.AND.ITYPE(IP1).EQ.'N')GOTO400
      IF(ITYPE(I).EQ.'LF'.AND.ITYPE(IP1).EQ.'X')GOTO400
      IF(ITYPE(I).EQ.'LF'.AND.ITYPE(IP1).EQ.'PAR')GOTO400
      IF(ITYPE(I).EQ.'COM')NUMSAV=NUMSAV+1
      IF(ITYPE(I).EQ.'COM')GOTO100
      WRITE(ICOUT,105)
  105 FORMAT('***** ERROR IN EVALM--',
     1'UNKNOWN ARGUMENT/OPERATION TYPE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,106)I,ITYPE(I)
  106 FORMAT('I,ITYPE(I) = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
  200 CONTINUE
      IF(NUMSAV.GE.1)GOTO250
      NTERM=NTERM+1
      TERM(NTERM)=W2(I)
      IOP(NTERM)='V'
CCCCC APRIL 1995.  INITIALIZE SAVE1, ... ,SAVE4.  BUG IN HEAVE
CCCCC FUNCTION (HEAVE(X,A,B), WHERE A AND B ARE BOTH OPTIONAL).
CCCCC SAVE1(ILIBC1)=(-99.9)
CCCCC SAVE2(ILIBC1)=(-99.9)
CCCCC SAVE3(ILIBC1)=(-99.9)
CCCCC SAVE4(ILIBC1)=(-99.9)
      GOTO100
  250 CONTINUE
CCCCC THE FOLLOWING 3 LINES WERE CHANGED     MAY 1994
CCCCC FOLLOWING SECTIONS MODIFIED FOR DOUBLY NON-CENTRAL F
CCCCC WHICH HAS 5 ARGUEMNTS.                 SEPTEMBER 1994.
CCCCC IF(NUMSAV.EQ.1)SAVE1=W2(I)
CCCCC IF(NUMSAV.EQ.2)SAVE2=W2(I)
CCCCC IF(NUMSAV.EQ.3)SAVE3=W2(I)
      IF(NUMSAV.EQ.1)THEN
         SAVE1(ILIBC1)=W2(I)
CCCCC    SAVE2(ILIBC1)=(-99.9)
CCCCC    SAVE3(ILIBC1)=(-99.9)
CCCCC    SAVE4(ILIBC1)=(-99.9)
      ENDIF
      IF(NUMSAV.EQ.2)THEN
         SAVE2(ILIBC1)=W2(I)
CCCCC    SAVE3(ILIBC1)=(-99.9)
CCCCC    SAVE4(ILIBC1)=(-99.9)
      ENDIF
      IF(NUMSAV.EQ.3)THEN
         SAVE3(ILIBC1)=W2(I)
CCCCC    SAVE4(ILIBC1)=(-99.9)
      ENDIF
      IF(NUMSAV.EQ.4)THEN
         SAVE4(ILIBC1)=W2(I)
      ENDIF
      IF(NUMSAV.EQ.5)THEN
         SAVE5(ILIBC1)=W2(I)
      ENDIF
      IF(NUMSAV.EQ.6)THEN
         SAVE6(ILIBC1)=W2(I)
      ENDIF
      IF(NUMSAV.EQ.7)THEN
         SAVE7(ILIBC1)=W2(I)
      ENDIF
      IF(NUMSAV.EQ.8)THEN
         SAVE8(ILIBC1)=W2(I)
      ENDIF
      GOTO100
C
  300 CONTINUE
      IF(IW2(I).EQ.'+')GOTO310
      IF(IW2(I).EQ.'-')GOTO310
      IF(IW2(I).EQ.'*')GOTO320
      IF(IW2(I).EQ.'/')GOTO320
      IF(IW2(I).EQ.'**')GOTO320
      WRITE(ICOUT,305)
  305 FORMAT('***** ERROR IN EVALM--',
     1'NOT ONE OF THE 5 OPERATIONS:  + - * / **')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,306)I,IW2(I),IW22(I)
  306 FORMAT('I,IW2(I),IW22(I) = ',I8,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  310 CONTINUE
      NOP=NOP+1
      IOP(NOP)=IW2(I)
      IF(NTERM.EQ.0)TERM(1)=0.0
      IF(NTERM.EQ.0)NTERM=1
      GOTO100
  320 NOP=NOP+1
      IOP(NOP)=IW2(I)
      IF(NTERM.EQ.0)WRITE(ICOUT,322)
  322 FORMAT('*, /, OR ** STARTS AN EXPRESSION')
      IF(NTERM.EQ.0)CALL DPWRST('XXX','BUG ')
      IF(NTERM.EQ.0)IERROR='YES'
      IF(NTERM.EQ.0)GOTO9000
CCCCC APRIL 1995.  ADD FOLLOWING LINE
CCCCC ILIBC2=ILIBC2+1
      GOTO100
C
  400 CONTINUE
C     PERFORM A LIBRARY FUNCTION EVALUATION.
      IF(IBUGEV.EQ.'ON')WRITE(ICOUT,331)
  331 FORMAT('IN EVALM, BEFORE ENTERING DPLIBF--')
      IF(IBUGEV.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IF(IBUGEV.EQ.'ON')WRITE(ICOUT,332)IW2(I),IW22(I),W2(IP1),IBUGEV
  332 FORMAT('IW2(I),IW22(I),W2(IP1),IBUGEV = ',A4,2X,A4,2X,F10.5,
     12X,A4)
      IF(IBUGEV.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
CCCCC THE SAVE3 ARGUMENT WAS ADDED MARCH 1989
CCCCC THE SAVE4 ARGUMENT WAS ADDED SEPTEMBER 1994.
CCCCC CALL DPLIBF(IW2(I),IW22(I),W2(IP1),SAVE1,SAVE2,SAVE3,I,IANGLU,
CCCCC1RESULT,IBUGEV,IERROR)
CCCCC CHANGE FOLLOWING LINE APRIL 1995
CCCCC CALL DPLIBF(IW2(I),IW22(I),W2(IP1),SAVE1,SAVE2,SAVE3,SAVE4,I,
      ILIBC2=ILIBC2+1
      IF(ILIBC2.GT.0)THEN
        ASAV1=SAVE1(ILIBC2)
        ASAV2=SAVE2(ILIBC2)
        ASAV3=SAVE3(ILIBC2)
        ASAV4=SAVE4(ILIBC2)
        ASAV5=SAVE5(ILIBC2)
        ASAV6=SAVE6(ILIBC2)
        ASAV7=SAVE7(ILIBC2)
        ASAV8=SAVE8(ILIBC2)
      ELSE
        ASAV1=0.0
        ASAV2=0.0
        ASAV3=0.0
        ASAV4=0.0
        ASAV5=0.0
        ASAV6=0.0
        ASAV7=0.0
        ASAV8=0.0
      ENDIF
      CALL DPLIBF(IW2(I),IW22(I),W2(IP1),ASAV1,ASAV2,ASAV3,ASAV4,
     1ASAV5,ASAV6,ASAV7,ASAV8,
     1I,
     1IANGLU,RESULT,IBUGEV,IERROR)
C
      IF(IBUGEV.EQ.'ON')WRITE(ICOUT,333)
  333 FORMAT('IN EVALM, AFTER RETURNING FROM DPLIBF--')
      IF(IBUGEV.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IF(IBUGEV.EQ.'ON')WRITE(ICOUT,334)RESULT,IERROR
  334 FORMAT('RESULT, IERROR = ',F20.10,2X,A4)
      IF(IBUGEV.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IF(IERROR.EQ.'YES')GOTO9000
      NTERM=NTERM+1
      TERM(NTERM)=RESULT
C
  490 CONTINUE
      IOP(NTERM)='V'
C
C     CHECK THAT NTERM HAS NOT EXCEEDED MAXTER (USUALLY 80)
C
      IF(NTERM.LE.MAXTER)GOTO1900
      WRITE(ICOUT,1901)
 1901 FORMAT('***** ERROR IN EVALM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1902)
 1902 FORMAT('      THE VARIABLE NTERM HAS JUST EXCEEDED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1903)
 1903 FORMAT('      THE MAX ALLOWABLE LIMIT DEFINED ',
     1'BY THE INTERNAL VARIABLE MAXTER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1904)MAXTER
 1904 FORMAT('      THIS LIMIT IS MAXTER = ',I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 1900 CONTINUE
C
      IDEL=2
  100 CONTINUE
      I=I+IDEL
      IF(I.LE.ISTOP)GOTO150
      IF(IBUGEV.EQ.'OFF')GOTO499
      WRITE(ICOUT,491)
  491 FORMAT('AFTER THE LIBRARY FUNCTIONS HAVE BEEN ',
     1'EVALUATED AND ELIMINATED--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,492)NTERM,NOP
  492 FORMAT('NTERM,NOP = ',2I6)
      CALL DPWRST('XXX','BUG ')
      DO493I=1,NTERM
      WRITE(ICOUT,494)I,TERM(I),IOP(I)
  494 FORMAT('I,TERM(I),IOP(I) = ',I6,E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
  493 CONTINUE
  499 CONTINUE
C
C               *******************************************************
C               **  STEP 2--                                         **
C               **  CHECK TO SEE THAT THE NUMBER OF TERMS =          **
C               **  ONE MORE THAN THE NUMBER OF OPERATIONS.          **
C               **  ALSO CHECK TO SEE IF THE SPECIAL CASE            **
C               **  EXISTS WHERE THERE IS ONLY 1 TERM--              **
C               **  IF SO, SET ANS = TO THIS FIRST TERM AND GOTO9000.  **
C               *******************************************************
C
      NOPP1=NOP+1
      IF(NTERM.EQ.NOPP1)GOTO550
      WRITE(ICOUT,560)
  560 FORMAT('***** ERROR IN EVALM--NUMBER OF TERMS ',
     1'NOT EQUAL TO NUMBER OF OPERATIONS + 1')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,566)NTERM,NOPP1
  566 FORMAT('NTERM,NOPP1 = ',I8,2X,I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  550 CONTINUE
      IF(NTERM.GE.2)GOTO990
      IF(NTERM.EQ.1)GOTO570
      WRITE(ICOUT,571)
  571 FORMAT('***** ERROR IN EVALM--',
     1'NUMBER OF TERMS = 0 AT END ',
     1'OF STEP 2 (LIBRARY FUNCTIONS ELIMINATED)')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  570 CONTINUE
      ANS=TERM(1)
      GOTO9000
  990 CONTINUE
C
C               ****************************************************************
C               **  STEP 3--
C               **  OPERATE ON THE TERM(.) AND IOP(.) VECTORS.
C               **  AT THIS POINT WE HAVE ONLY ALTERNATING TERMS AND OPERATIONS
C               **  WHERE AN OPERATION IS ANY ONE OF THE 5--
C               **  +   -   *   /   **.
C               **  EVALUATE AND ELIMINATE ALL **.
C               **  SQUEEZE THE TERM(.) AND IOP(.) VECTORS UNTIL
C               **  UNTIL ALL ** ARE GONE.
C               ****************************************************************
C
 1000 CONTINUE
      I=1
 1100 CONTINUE
      IF(IOP(I).EQ.'**')GOTO1200
      GOTO1300
C
 1200 CONTINUE
      IP1=I+1
 1210 CONTINUE
      T1=TERM(I)
      T2=TERM(IP1)
      T3=ABS(T1)
      T4=ABS(T2)
      T34=0.0
      IF(T3.GT.0.0.AND.T4.GT.0.0)T34=T4*ALOG(T3)
      IF(T34.GT.ALCPUM)GOTO1211
      IF(T1.NE.CPUMIN.AND.T1.NE.CPUMAX.AND.
     1   T2.NE.CPUMIN.AND.T2.NE.CPUMAX)GOTO1219
      IF(T1.EQ.CPUMIN.AND.T4.LE.1.0)GOTO1219
      IF(T2.EQ.CPUMIN.AND.T3.LE.1.0)GOTO1219
      IF(T1.EQ.CPUMAX.AND.T4.LE.1.0)GOTO1219
      IF(T2.EQ.CPUMAX.AND.T3.LE.1.0)GOTO1219
 1211 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1212)
 1212 FORMAT('***** ERROR IN EVALM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1213)
 1213 FORMAT('      ATTEMPT TO CARRY OUT AN OPERATION ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1214)
 1214 FORMAT('      WHICH RESULTS IN AN OUT-OF-RANGE NUMBER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1215)
 1215 FORMAT('      THE OPERATION      = **')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1216)T1
 1216 FORMAT('      THE FIRST  OPERAND = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1217)T2
 1217 FORMAT('      THE SECOND OPERAND = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 1219 CONTINUE
C
 1220 CONTINUE
      IF(T1.NE.0.0)GOTO1229
CCCCC BUG FIX.  IF T2 IS POSITIVE, SET 0**T2 TO ZERO.  NOVEMBER 1998.
CCCCC IF(T2.GT.0.0)GOTO1229
      IF(T2.GT.0.0)THEN
        TERM(I)=0.0
        GOTO1239
      ENDIF
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1221)
 1221 FORMAT('***** ERROR IN EVALM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1222)
 1222 FORMAT('      ATTEMPT TO RAISE A ZERO NUMBER ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1223)
 1223 FORMAT('      TO A ZERO OR NEGATIVE POWER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1226)T2
 1226 FORMAT('      THE POWER           = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 1229 CONTINUE
      IF(T1.GT.0.0)GOTO1237
C
CCCCC T6=AINT(T2)
CCCCC REM=T2-T6
CCCCC ABSREM=ABS(REM)
      ABST2=ABS(T2)
      ISIGN=(-1)
      IF(T2.GE.0.0)ISIGN=1
      IABST2=ABST2+0.5
      AIABS2=IABST2
      REM=ABST2-AIABS2
      ABSREM=ABS(REM)
      IF(ABSREM.GE.CUTOFF)GOTO1230
      IF(IBUGEV.EQ.'ON')WRITE(ICOUT,7777)T1,T2,ABST2,ISIGN,IABST2
 7777 FORMAT('T1,T2,ABST2,ISIGN,IABST2 = ',3E15.7,2I8)
      IF(IBUGEV.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IF(IBUGEV.EQ.'ON')WRITE(ICOUT,7778)AIABS2,REM,ABSREM,TERM(I)
 7778 FORMAT('AIABS2,REM,ABSREM,TERM(I) = ',4E15.7)
      IF(IBUGEV.EQ.'ON')CALL DPWRST('XXX','BUG ')
      TERM(I)=TERM(I)**(ISIGN*IABST2)
      GOTO1239
C
 1230 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1231)
 1231 FORMAT('***** ERROR IN EVALM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1232)
 1232 FORMAT('      ATTEMPT TO RAISE A NEGATIVE NUMBER ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1233)
 1233 FORMAT('      TO A FRACTIONAL POWER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1235)T1
 1235 FORMAT('      THE NEGATIVE NUMBER = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1236)T2
 1236 FORMAT('      THE POWER           = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 1237 CONTINUE
      IF(IBUGEV.EQ.'ON')WRITE(ICOUT,1238)I,TERM(I),TERM(IP1),T1,T2,
     1AIABS2,REM
 1238 FORMAT('I,TERM(I),TERM(IP1),T1,T2,AIABS2,REM = ',I4,6E14.6)
      IF(IBUGEV.EQ.'ON')CALL DPWRST('XXX','BUG ')
CCCCC FOLLOWING LINE SEEMS TO SHOW A COMPILER BUG FOR THE OLDER LAHEY
CCCCC COMPILER.  WORKAROUND FOR THIS COMPILER.   SEPTEMBER 1997.
CCCCC TERM(I)=TERM(I)**TERM(IP1)
      IF(ICOMPI.NE.'LAHE')THEN
        TERM(I)=TERM(I)**TERM(IP1)
      ELSE
        ATEMP1=TERM(IP1)*ALOG(TERM(I))
        TERM(I)=EXP(ATEMP1)
      ENDIF
      GOTO1239
C
 1239 CONTINUE
CCCCC CALL EVEXP(TERM(I),TERM(IP1),RESULT)
CCCCC TERM(I)=RESULT
      NOPM1=NOP-1
      IF(I.GE.NOP)GOTO1490
      DO1400J=I,NOPM1
      JP1=J+1
      JP2=J+2
      IOP(J)=IOP(JP1)
      TERM(JP1)=TERM(JP2)
 1400 CONTINUE
 1490 CONTINUE
      NOP=NOPM1
      GOTO1350
 1300 CONTINUE
      I=I+1
 1350 CONTINUE
      IF(I.LE.NOP)GOTO1100
 1500 CONTINUE
      NTERM=NOP+1
      IF(IBUGEV.EQ.'OFF')GOTO1990
      WRITE(ICOUT,1991)
 1991 FORMAT('AFTER THE ** HAVE BEEN ',
     1'EVALUATED AND ELIMINATED--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1992)NTERM,NOP
 1992 FORMAT('NTERM,NOP = ',2I6)
      CALL DPWRST('XXX','BUG ')
      DO1993I=1,NTERM
      WRITE(ICOUT,1994)I,TERM(I),IOP(I)
 1994 FORMAT('I,TERM(I),IOP(I) = ',I6,E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
 1993 CONTINUE
 1990 CONTINUE
C
C               ****************************************************************
C               **  STEP 4--
C               **  OPERATE ON THE TERM(.) AND IOP(.) VECTORS.
C               **  AT THIS POINT WE HAVE ONLY ALTERNATING TERMS AND OPERATIONS
C               **  WHERE AN OPERATION IS ANY ONE OF THE 4--
C               **  +   -   *   /   .
C               **  EVALUATE AND ELIMINATE ALL * AND / IN SEQUENCE.
C               **  SQUEEZE THE TERM(.) AND IOP(.) VECTORS UNTIL
C               **  UNTIL ALL * AND / ARE GONE.
C               ****************************************************************
C
 2000 CONTINUE
      I=1
 2100 CONTINUE
      IF(IOP(I).EQ.'*')GOTO2210
      IF(IOP(I).EQ.'/')GOTO2220
      GOTO2300
 2210 CONTINUE
      IP1=I+1
      T1=TERM(I)
      T2=TERM(IP1)
      T3=ABS(T1)
      T4=ABS(T2)
      T34=0.0
      IF(T3.GT.0.0.AND.T4.GT.0.0)T34=ALOG(T3)+ALOG(T4)
      IF(T34.GT.ALCPUM)GOTO2211
CCCCC THE FOLLOWING 2 LINES WERE INSERTED JUNE 1989
      IF(T34.LT.-ALCPUM)TERM(I)=0.0
      IF(T34.LT.-ALCPUM)GOTO2250
      IF(T1.NE.CPUMIN.AND.T1.NE.CPUMAX.AND.
     1   T2.NE.CPUMIN.AND.T2.NE.CPUMAX)GOTO2219
      IF(T1.EQ.CPUMIN.AND.T4.LE.1.0)GOTO2219
      IF(T2.EQ.CPUMIN.AND.T3.LE.1.0)GOTO2219
      IF(T1.EQ.CPUMAX.AND.T4.LE.1.0)GOTO2219
      IF(T2.EQ.CPUMAX.AND.T3.LE.1.0)GOTO2219
 2211 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2212)
 2212 FORMAT('***** ERROR IN EVALM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2213)
 2213 FORMAT('      ATTEMPT TO CARRY OUT AN OPERATION ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2214)
 2214 FORMAT('      WHICH RESULTS IN AN OUT-OF-RANGE NUMBER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2215)
 2215 FORMAT('      THE OPERATION      = *')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2216)T1
 2216 FORMAT('      THE FIRST  OPERAND = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2217)T2
 2217 FORMAT('      THE SECOND OPERAND = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 2219 CONTINUE
      TERM(I)=TERM(I)*TERM(IP1)
      GOTO2250
C
 2220 CONTINUE
      IP1=I+1
      T1=TERM(I)
      T2=TERM(IP1)
      T3=ABS(T1)
      T4=ABS(T2)
      T34=0.0
      IF(T3.GT.0.0.AND.T4.GT.0.0)T34=ALOG(T3)-ALOG(T4)
      IF(T34.GT.ALCPUM)GOTO2221
CCCCC THE FOLLOWING 2 LINES WERE INSERTED JUNE 1989
      IF(T34.LT.-ALCPUM)TERM(I)=0.0
      IF(T34.LT.-ALCPUM)GOTO2250
      IF(T1.NE.CPUMIN.AND.T1.NE.CPUMAX.AND.
     1   T2.NE.CPUMIN.AND.T2.NE.CPUMAX)GOTO2229
      IF(T1.EQ.CPUMIN.AND.T4.GE.1.0)GOTO2229
      IF(T1.EQ.CPUMAX.AND.T4.GE.1.0)GOTO2229
 2221 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2222)
 2222 FORMAT('***** ERROR IN EVALM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2223)
 2223 FORMAT('      ATTEMPT TO CARRY OUT AN OPERATION ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2224)
 2224 FORMAT('      WHICH RESULTS IN AN OUT-OF-RANGE NUMBER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2225)
 2225 FORMAT('      THE OPERATION      = /')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2226)T1
 2226 FORMAT('      THE FIRST  OPERAND = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2227)T2
 2227 FORMAT('      THE SECOND OPERAND = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 2229 CONTINUE
      IF(T2.NE.0.0)GOTO2239
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2231)
 2231 FORMAT('***** ERROR IN EVALM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2232)
 2232 FORMAT('      ATTEMPT TO DIVIDE A NUMBER ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2233)
 2233 FORMAT('      BY ZERO.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2235)T1
 2235 FORMAT('      THE NUMERATOR   = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2236)T2
 2236 FORMAT('      THE DENOMINATOR = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 2239 CONTINUE
      TERM(I)=TERM(I)/TERM(IP1)
      GOTO2250
C
 2250 CONTINUE
      NOPM1=NOP-1
      IF(I.GE.NOP)GOTO2490
      DO2400J=I,NOPM1
      JP1=J+1
      JP2=J+2
      IOP(J)=IOP(JP1)
      TERM(JP1)=TERM(JP2)
 2400 CONTINUE
 2490 CONTINUE
      NOP=NOPM1
      GOTO2350
 2300 CONTINUE
      I=I+1
 2350 CONTINUE
      IF(I.LE.NOP)GOTO2100
 2500 CONTINUE
      NTERM=NOP+1
      IF(IBUGEV.EQ.'OFF')GOTO2990
      WRITE(ICOUT,2991)
 2991 FORMAT('AFTER THE * AND / HAVE BEEN ',
     1'EVALUATED AND ELIMINATED--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2992)NTERM,NOP
 2992 FORMAT('NTERM,NOP = ',2I6)
      CALL DPWRST('XXX','BUG ')
      DO2993I=1,NTERM
      WRITE(ICOUT,2994)I,TERM(I),IOP(I)
 2994 FORMAT('I,TERM(I),IOP(I) = ',I6,E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
 2993 CONTINUE
 2990 CONTINUE
C
C               ****************************************************************
C               **  STEP 5--
C               **  OPERATE ON THE TERM(.) AND IOP(.) VECTORS.
C               **  AT THIS POINT WE HAVE ONLY ALTERNATING TERMS AND OPERATIONS
C               **  WHERE AN OPERATION IS ANY ONE OF THE 2--
C               **  + OR - .
C               **  EVALUATE ALL + OR - OPERATIONS IN SEQUENCE.
C               **  SQUEEZE THE TERM(.) AND IOP(.) VECTORS UNTIL
C               **  UNTIL ALL + AND - OPERATIONS ARE GONE.
C               ****************************************************************
C
 3000 CONTINUE
      IF(NOP.GE.1)GOTO3100
      ANS=TERM(1)
      GOTO9000
 3100 CONTINUE
      ANS=TERM(1)
      DO3200I=1,NOP
      IP1=I+1
      IF(IOP(I).EQ.'+')GOTO3210
      IF(IOP(I).EQ.'-')GOTO3220
      GOTO3210
 3210 CONTINUE
      T1=TERM(I)
      T2=TERM(IP1)
      IF(T1.NE.CPUMIN.AND.T1.NE.CPUMAX.AND.
     1   T2.NE.CPUMIN.AND.T2.NE.CPUMAX)GOTO3219
      IF(T1.EQ.CPUMIN.AND.T2.GE.0.0)GOTO3219
      IF(T2.EQ.CPUMIN.AND.T1.GE.0.0)GOTO3219
      IF(T1.EQ.CPUMAX.AND.T2.LE.0.0)GOTO3219
      IF(T2.EQ.CPUMAX.AND.T1.LE.0.0)GOTO3219
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3211)
 3211 FORMAT('***** ERROR IN EVALM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3212)
 3212 FORMAT('      ATTEMPT TO CARRY OUT AN OPERATION ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3213)
 3213 FORMAT('      WHICH RESULTS IN AN OUT-OF-RANGE NUMBER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3214)
 3214 FORMAT('      THE OPERATION      = +')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3215)T1
 3215 FORMAT('      THE FIRST  OPERAND = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3216)T2
 3216 FORMAT('      THE SECOND OPERAND = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 3219 CONTINUE
      ANS=ANS+TERM(IP1)
      GOTO3200
C
 3220 CONTINUE
      T1=TERM(I)
      T2=TERM(IP1)
      IF(T1.NE.CPUMIN.AND.T1.NE.CPUMAX.AND.
     1   T2.NE.CPUMIN.AND.T2.NE.CPUMAX)GOTO3229
      IF(T1.EQ.CPUMIN.AND.T2.LE.0.0)GOTO3229
      IF(T2.EQ.CPUMIN.AND.T1.LE.0.0)GOTO3229
      IF(T1.EQ.CPUMAX.AND.T2.GE.0.0)GOTO3229
      IF(T2.EQ.CPUMAX.AND.T1.GE.0.0)GOTO3229
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3221)
 3221 FORMAT('***** ERROR IN EVALM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3222)
 3222 FORMAT('      ATTEMPT TO CARRY OUT AN OPERATION ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3223)
 3223 FORMAT('      WHICH RESULTS IN AN OUT-OF-RANGE NUMBER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3224)
 3224 FORMAT('      THE OPERATION      = -')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3225)T1
 3225 FORMAT('      THE FIRST  OPERAND = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3226)T2
 3226 FORMAT('      THE SECOND OPERAND = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 3229 CONTINUE
      ANS=ANS-TERM(IP1)
      GOTO3200
 3200 CONTINUE
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGEV.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF EVALM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)ANS,IERROR
 9012 FORMAT('ANS,IERROR = ',E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
      DO9113I=1,5
      WRITE(ICOUT,9013)I,SAVE1(I),SAVE2(I),SAVE3(I),SAVE4(I)
 9013 FORMAT('I,SAVE1,SAVE2,SAVE3,SAVE4 = ',I3,5E15.7)
      CALL DPWRST('XXX','BUG ')
 9113 CONTINUE
      WRITE(ICOUT,9014)IBUGEV
 9014 FORMAT('IBUGEV = ',A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE EWECDF(X,GAMMA,THETA,MINMAX,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE EXPONENTIATED WEIBULL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA, SHAPE PARAMETER THETA.
C              THERE ARE 2 SUCH EXPONETIATED WEIBULL FAMILIES--
C                 ONE FOR THE MIN ORDER STAT (THE USUAL) AND
C                 ONE FOR THE MAX ORDER STAT.
C              (SEE SARHAN & GREENBERG, PAGE 69)
C              THE EXPONETIATED WEIBULL TYPE IS SPECIFIED VIA   MINMAX
C              FOR MINMAX = 1  (FOR THE DEFAULT MINIMUM)
C                 THE EXPONETIATED EXPONENTIATED WEIBULL DISTRIBUTION USED
C                 HEREIN IS DEFINED FOR ALL POSITIVE X,
C                 AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X) = (THETA*GAMMA)*(X**(GAMMA-1)) * EXP(-(X**GAMMA))
C                        *(1-EXP(-(X**GAMMA))**(THETA-1)
C              FOR MINMAX = 2 (FOR THE MAXIMUM),
C                 THE EXPONETIATED EXPONENTIATED WEIBULL DISTRIBUTION USED
C                 HEREIN IS DEFINED FOR ALL NEGATIVE X,
C                 AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X) = ...
C                 F(X) = GAMMA * (X**(GAMMA-1)) * EXP(-(X**GAMMA)).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C                     --THETA  = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                                THETA SHOULD BE POSITIVE.
C                     --MINMAX = THE INTEGER VALUE
C                                IDENTIFYING THE
C                                CHOSEN EXPONENTIATED WEIBULL DISTRIBUTION.
C                                1 = MIN, 2 = MAX.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE EXPONENTIATED WEIBULL DISTRIBUTION
C             WITH TAIL LENGHT PARAMETER = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--SARHAN & GREENBERG,
C                 CONTRIBUTIONS TO ORDER STATISTICS,
C                 1962, WILEY, PAGE 69.
C               --MUDHOLKAR AND SRIVASTAVE, "THE EXPONENTIATED WEIBULL
C                 FAMILY: A REANALYSIS OF THE BUS-MOTOR-FAILURE DATA",
C                 TECHNOMETRICS, NOVEMBER, 1995, PP436-437.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--95/10
C     ORIGINAL VERSION--OCTOBER   1995.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DG
      DOUBLE PRECISION DT
      DOUBLE PRECISION DTERM1, DTERM2
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.LE.0)GOTO50
      IF(THETA.LE.0)GOTO65
      GOTO90
   50 WRITE(ICOUT,15)
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'EWECDF SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)GAMMA
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   65 WRITE(ICOUT,25)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)THETA
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   25 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'EWECDF SUBROUTINE IS NON-POSITIVE *****')
   90 CONTINUE
C
       IF(X.LE.0.0)THEN
         CDF=0.0
       ELSE 
         DX=DBLE(X)
         DG=DBLE(GAMMA)
         DT=DBLE(THETA)
         DTERM1=DLOG(1.0D0-DEXP(-(DX**DG)))
         DTERM2=DT*DTERM1
         DCDF=DEXP(DTERM2)
         CDF=SNGL(DCDF)
      ENDIF
C
      RETURN
      END
      SUBROUTINE EWECHA(X,GAMMA,THETA,MINMAX,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE EXPONENTIATED WEIBULL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA, SHAPE PARAMETER THETA.
C              FOR MINMAX = 1  (FOR THE DEFAULT MINIMUM)
C                 THE EXPONETIATED EXPONENTIATED WEIBULL DISTRIBUTION USED
C                 HEREIN IS DEFINED FOR ALL POSITIVE X,
C                 AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X) = (THETA*GAMMA)*(X**(GAMMA-1)) * EXP(-(X**GAMMA))
C                        *(1-EXP(-(X**GAMMA))**(THETA-1)
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C                     --THETA  = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                                THETA SHOULD BE POSITIVE.
C                     --MINMAX = THE INTEGER VALUE
C                                IDENTIFYING THE
C                                CHOSEN EXPONENTIATED WEIBULL DISTRIBUTION.
C                                1 = MIN, 2 = MAX.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION CUMULATIVE HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD
C             FUNCTION VALUE FOR THE EXPONENTIATED WEIBULL DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER GAMMA, SHAPE PARAMETER THETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE
C                 --GAMMA, THETA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--MUDHOLKAR AND SRIVASTAVE, "THE EXPONENTIATED WEIBULL
C                 FAMILY: A REANALYSIS OF THE BUS-MOTOR-FAILURE DATA",
C                 TECHNOMETRICS, NOVEMBER, 1995, PP436-437.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--98/5
C     ORIGINAL VERSION--MAY       1998.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DHAZ
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DG
      DOUBLE PRECISION DT
      DOUBLE PRECISION DTERM1, DTERM2
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.LE.0)GOTO50
      IF(THETA.LE.0)GOTO65
      GOTO90
   50 WRITE(ICOUT,15)
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'EWECHA SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)GAMMA
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      CALL DPWRST('XXX','BUG ')
      HAZ=0.0
      RETURN
   65 WRITE(ICOUT,25)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)THETA
      CALL DPWRST('XXX','BUG ')
      HAZ=0.0
      RETURN
   25 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'EWECHA SUBROUTINE IS NON-POSITIVE *****')
   90 CONTINUE
C
      IF(X.LE.0.0)THEN
        HAZ=0.0
      ELSE
C
        DX=DBLE(X)
        DT=DBLE(THETA)
        DG=DBLE(GAMMA)
        DTERM1=DLOG(1.0D0-DEXP(-(DX**DG)))
        DTERM2=DT*DTERM1
        DCDF=DEXP(DTERM2)
C
        DHAZ=-DLOG(1.0D0-DCDF)
        HAZ=SNGL(DHAZ)
C
      ENDIF
C
      RETURN
      END
      SUBROUTINE EWEHAZ(X,GAMMA,THETA,MINMAX,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE EXPONENTIATED WEIBULL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA, SHAPE PARAMETER THETA.
C              FOR MINMAX = 1  (FOR THE DEFAULT MINIMUM)
C                 THE EXPONETIATED EXPONENTIATED WEIBULL DISTRIBUTION USED
C                 HEREIN IS DEFINED FOR ALL POSITIVE X,
C                 AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X) = (THETA*GAMMA)*(X**(GAMMA-1)) * EXP(-(X**GAMMA))
C                        *(1-EXP(-(X**GAMMA))**(THETA-1)
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C                     --THETA  = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                                THETA SHOULD BE POSITIVE.
C                     --MINMAX = THE INTEGER VALUE
C                                IDENTIFYING THE
C                                CHOSEN EXPONENTIATED WEIBULL DISTRIBUTION.
C                                1 = MIN, 2 = MAX.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION HAZARD FUNCTION
C                                VALUE.
C     OUTPUT--THE SINGLE PRECISION HAZARD
C             FUNCTION VALUE FOR THE EXPONENTIATED WEIBULL DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER GAMMA, SHAPE PARAMETER THETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE
C                 --GAMMA, THETA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--MUDHOLKAR AND SRIVASTAVE, "THE EXPONENTIATED WEIBULL
C                 FAMILY: A REANALYSIS OF THE BUS-MOTOR-FAILURE DATA",
C                 TECHNOMETRICS, NOVEMBER, 1995, PP436-437.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--98/5
C     ORIGINAL VERSION--MAY       1998.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DHAZ
      DOUBLE PRECISION DX
      DOUBLE PRECISION DG
      DOUBLE PRECISION DT
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5
      DOUBLE PRECISION DTERM6
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.LE.0)GOTO50
      IF(THETA.LE.0)GOTO65
      GOTO90
   50 WRITE(ICOUT,15)
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'EWEHAZ SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)GAMMA
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      CALL DPWRST('XXX','BUG ')
      HAZ=0.0
      RETURN
   65 WRITE(ICOUT,25)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)THETA
      CALL DPWRST('XXX','BUG ')
      HAZ=0.0
      RETURN
   25 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'EWEHAZ SUBROUTINE IS NON-POSITIVE *****')
   90 CONTINUE
C
      IF(X.LE.0.0)THEN
        HAZ=0.0
      ELSE
        DX=DBLE(X)
        DT=DBLE(THETA)
        DG=DBLE(GAMMA)
C
        DTERM1=DLOG(DG) + DLOG(DT)
        DTERM2=(DT-1.0D0)*DLOG(1.0D0-DEXP(-(DX**DG)))
        DTERM3=-(DX**DG)
        DTERM4=(DG-1.0D0)*DLOG(DX)
        DTERM5=DLOG(1.0D0 - (1.0D0 - DEXP(-(DX**DG))**DT))
        DTERM6=DTERM1+DTERM2+DTERM3+DTERM4-DTERM5
        DHAZ=DEXP(DTERM6)
        HAZ=SNGL(DHAZ)
C
      ENDIF
C
      RETURN
      END
      SUBROUTINE EWEPDF(X,GAMMA,THETA,MINMAX,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE EXPONENTIATED WEIBULL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA, SHAPE PARAMETER THETA.
C              THERE ARE 2 SUCH EXPONETIATED WEIBULL FAMILIES--
C                 ONE FOR THE MIN ORDER STAT (THE USUAL) AND
C                 ONE FOR THE MAX ORDER STAT.
C              (SEE SARHAN & GREENBERG, PAGE 69)
C              THE EXPONETIATED WEIBULL TYPE IS SPECIFIED VIA   MINMAX
C              FOR MINMAX = 1  (FOR THE DEFAULT MINIMUM)
C                 THE EXPONETIATED EXPONENTIATED WEIBULL DISTRIBUTION USED
C                 HEREIN IS DEFINED FOR ALL POSITIVE X,
C                 AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X) = (THETA*GAMMA)*(X**(GAMMA-1)) * EXP(-(X**GAMMA))
C                        *(1-EXP(-(X**GAMMA))**(THETA-1)
C              FOR MINMAX = 2 (FOR THE MAXIMUM),
C                 THE EXPONETIATED EXPONENTIATED WEIBULL DISTRIBUTION USED
C                 HEREIN IS DEFINED FOR ALL NEGATIVE X,
C                 AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X) = ...
C                 F(X) = GAMMA * (X**(GAMMA-1)) * EXP(-(X**GAMMA)).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C                     --THETA  = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                                THETA SHOULD BE POSITIVE.
C                     --MINMAX = THE INTEGER VALUE
C                                IDENTIFYING THE
C                                CHOSEN EXPONENTIATED WEIBULL DISTRIBUTION.
C                                1 = MIN, 2 = MAX.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE FOR THE EXPONENTIATED WEIBULL DISTRIBUTION
C             WITH TAIL LENGHT PARAMETER = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--SARHAN & GREENBERG,
C                 CONTRIBUTIONS TO ORDER STATISTICS,
C                 1962, WILEY, PAGE 69.
C               --MUDHOLKAR AND SRIVASTAVE, "THE EXPONENTIATED WEIBULL
C                 FAMILY: A REANALYSIS OF THE BUS-MOTOR-FAILURE DATA",
C                 TECHNOMETRICS, NOVEMBER, 1995, PP436-437.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--95/10
C     ORIGINAL VERSION--OCTOBER   1995.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DG
      DOUBLE PRECISION DT
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.LE.0)GOTO50
      IF(THETA.LE.0)GOTO65
      GOTO90
   50 WRITE(ICOUT,15)
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'EWEPDF SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)GAMMA
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      CALL DPWRST('XXX','BUG ')
      PDF=0.0
      RETURN
   65 WRITE(ICOUT,25)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)THETA
      CALL DPWRST('XXX','BUG ')
      PDF=0.0
      RETURN
   25 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'EWEPDF SUBROUTINE IS NON-POSITIVE *****')
   90 CONTINUE
C
       IF(X.LE.0.0)THEN
         PDF=0.0
       ELSE
         DX=DBLE(X)
         IF(DX.LT.0.0000001D0)DX=0.0000001D0
         DG=DBLE(GAMMA)
         DT=DBLE(THETA)
         DTERM1=DLOG(DG) + DLOG(DT)
         DTERM2=(DT-1.0D0)*DLOG(1.0D0-DEXP(-(DX**DG)))
         DTERM3=-(DX**DG)
         DTERM4=(DG-1.0D0)*DLOG(DX)
         DTERM5=DTERM1+DTERM2+DTERM3+DTERM4
         DPDF=DEXP(DTERM5)
         PDF=SNGL(DPDF)
      ENDIF
C
      RETURN
      END
      SUBROUTINE EWEPPF(P,GAMMA,THETA,MINMAX,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE EXPONETIATED WEIBULL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA, SHAPE PARAMETER THETA.
C              THERE ARE 2 SUCH EXPONETIATED WEIBULL FAMILIES--
C                 ONE FOR THE MIN ORDER STAT (THE USUAL) AND
C                 ONE FOR THE MAX ORDER STAT.
C              (SEE SARHAN & GREENBERG, PAGE 69)
C              THE EXPONETIATED WEIBULL TYPE IS SPECIFIED VIA   MINMAX
C              FOR MINMAX = 1  (FOR THE DEFAULT MINIMUM)
C                 THE EXPONETIATED WEIBULL DISTRIBUTION USED
C                 HEREIN IS DEFINED FOR ALL POSITIVE X,
C                 AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X) = (THETA*GAMMA)*(X**(GAMMA-1)) * EXP(-(X**GAMMA))
C                        *(1-EXP(-(X**GAMMA))**(THETA-1)
C              FOR MINMAX = 2 (FOR THE MAXIMUM),
C                 THE EXPONETIATED WEIBULL DISTRIBUTION USED
C                 HEREIN IS DEFINED FOR ALL NEGATIVE X,
C                 AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X) = ...
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (INCLUSIVELY)
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C                     --THETA  = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                                THETA SHOULD BE POSITIVE.
C                     --MINMAX = THE INTEGER VALUE
C                                IDENTIFYING THE
C                                CHOSEN EXPONETIATED WEIBULL DISTRIBUTION.
C                                1 = MIN, 2 = MAX.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION .
C             VALUE PPF FOR THE EXPONETIATED WEIBULL DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--GAMMA SHOULD BE POSITIVE.
C                 --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--SARHAN & GREENBERG,
C                 CONTRIBUTIONS TO ORDER STATISTICS,
C               --MUDHOLKAR AND SRIVASTAVE, "THE EXPONENTIATED WEIBULL
C                 FAMILY: A REANALYSIS OF THE BUS-MOTOR-FAILURE DATA",
C                 TECHNOMETRICS, NOVEMBER, 1995, PP436-437.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--95/10
C     ORIGINAL VERSION--OCTOBER   1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DG
      DOUBLE PRECISION DT
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DTERM1
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GE.1.0)GOTO50
      IF(GAMMA.LE.0.0)GOTO55
      IF(THETA.LE.0.0)GOTO65
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   55 WRITE(ICOUT,15)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)GAMMA
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   65 WRITE(ICOUT,25)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)THETA
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'EWEPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'EWEPPF SUBROUTINE IS NON-POSITIVE *****')
   25 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'EWEPPF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
       IF(P.EQ.0.0)THEN
         PPF=0.0
       ELSE
         DP=DBLE(P)
         DG=DBLE(1.0/GAMMA)
         DT=DBLE(1.0/THETA)
         DTERM1=DG*DLOG(-DLOG(1.0D0-DP**DT))
         DPPF=DEXP(DTERM1)
         PPF=SNGL(DPPF)
      ENDIF
C
      RETURN
      END
      SUBROUTINE EWERAN(N,GAMMA,THETA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE EXPONENTIATED WEIBULL DISTRIBUTION
C              WITH SHAPE PARAMETER VALUES = GAMMA, THETA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE OF THE
C                                FIRST SHAPE PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C                     --THETA  = THE SINGLE PRECISION VALUE OF THE
C                                SECOND SHAPE PARAMETER.
C                                THETA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE EXPONENTIATED WEIBULL DISTRIBUTION
C             WITH SHAPE PARAMETER VALUES = GAMMA AND THETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NON E.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2001.9
C     ORIGINAL VERSION--SEPTEMBER 2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'EWERAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N EXPONENTIATED WEIBULL DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      MINMAX=1
      DO100I=1,N
        CALL EWEPPF(X(I),GAMMA,THETA,MINMAX,XTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION EXP3(XVALUE)
C
C   DESCRIPTION
C
C      This function calculates 
C          
C           EXP3(X) = integral 0 to X  (exp(-t*t*t)) dt
C
C      The code uses Chebyshev expansions, whose coefficients are
C      given to 20 decimal places.
C
C
C   ERROR RETURNS
C     
C      If XVALUE < 0, an error message is printed and the function 
C      returns the value 0.
C
C
C   MACHINE-DEPENDENT CONSTANTS
C
C      NTERM1 - INTEGER - The no. of terms of the array AEXP3,
C                         The recommended value is such that
C                               AEXP3(NTERM1) < EPS/100. 
C
C      NTERM2 - INTEGER - The no. of terms of the array AEXP3A.
C                         The recommended value is such that
C                               AEXP3A(NTERM2) < EPS/100.
C
C      XLOW - DOUBLE PRECISION - The value below which EXP3(X) = X to machine
C                    precision. The recommended value is
C                          cube root(4*EPSNEG)
C
C      XUPPER - DOUBLE PRECISION - The value above which EXP3(X) = 0.89297...
C                      to machine precision. The recommended value is
C                           cube root(-ln(EPSNEG))
C
C      For values of EPS and EPSNEG for various machine/compiler
C      combinations refer to the file MACHCON.TXT.
C
C      The machine-dependent constants are computed internally by
C      using the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED
C
C      EXP, LOG
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR
C
C      DR. ALLAN J. MACLEOD,
C      DEPARTMENT OF MATHEMATICS AND STATISTICS,
C      UNIVERSITY OF PAISLEY,
C      HIGH ST.,
C      PAISLEY
C      SCOTLAND.
C
C      (e-mail  macl_ms0@paisley.ac.uk )
C
C
C   LATEST MODIFICATION:  23 January, 1996
C
C
      INTEGER NTERM1,NTERM2
      DOUBLE PRECISION AEXP3(0:24),AEXP3A(0:24),CHEVAL,
     1      FOUR,FUNINF,HALF,ONE,ONEHUN,SIXTEN,T,THREE,
     2      TWO,X,XLOW,XUPPER,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*14
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC DATA FNNAME/'EXP3  '/
CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/
      DATA ZERO,HALF,ONE/0.0 D 0 , 0.5 D 0 , 1.0 D 0/
      DATA TWO,THREE,FOUR/2.0 D 0 , 3.0 D 0 , 4.0 D 0 /
      DATA SIXTEN,ONEHUN/16.0 D 0 , 100.0 D 0/
      DATA FUNINF/0.89297 95115 69249 21122 D 0/
      DATA AEXP3(0)/  1.26919 84142 21126 01434  D    0/
      DATA AEXP3(1)/ -0.24884 64463 84140 98226  D    0/
      DATA AEXP3(2)/  0.80526 22071 72310 4125   D   -1/
      DATA AEXP3(3)/ -0.25772 73325 19683 2934   D   -1/
      DATA AEXP3(4)/  0.75998 78873 07377 429    D   -2/
      DATA AEXP3(5)/ -0.20306 95581 94040 510    D   -2/
      DATA AEXP3(6)/  0.49083 45866 99329 17     D   -3/
      DATA AEXP3(7)/ -0.10768 22391 42020 77     D   -3/
      DATA AEXP3(8)/  0.21551 72626 42898 4      D   -4/
      DATA AEXP3(9)/ -0.39567 05137 38429        D   -5/
      DATA AEXP3(10)/ 0.66992 40933 8956         D   -6/
      DATA AEXP3(11)/-0.10513 21808 0703         D   -6/
      DATA AEXP3(12)/ 0.15362 58019 825          D   -7/
      DATA AEXP3(13)/-0.20990 96036 36           D   -8/
      DATA AEXP3(14)/ 0.26921 09538 1            D   -9/
      DATA AEXP3(15)/-0.32519 52422              D  -10/
      DATA AEXP3(16)/ 0.37114 8157               D  -11/
      DATA AEXP3(17)/-0.40136 518                D  -12/
      DATA AEXP3(18)/ 0.41233 46                 D  -13/
      DATA AEXP3(19)/-0.40337 5                  D  -14/
      DATA AEXP3(20)/ 0.37658                    D  -15/
      DATA AEXP3(21)/-0.3362                     D  -16/
      DATA AEXP3(22)/ 0.288                      D  -17/
      DATA AEXP3(23)/-0.24                       D  -18/
      DATA AEXP3(24)/ 0.2                        D  -19/
      DATA AEXP3A(0)/  1.92704 64955 06827 37293  D    0/
      DATA AEXP3A(1)/ -0.34929 35652 04813 8054   D   -1/
      DATA AEXP3A(2)/  0.14503 38371 89830 093    D   -2/
      DATA AEXP3A(3)/ -0.89253 36718 32790 3      D   -4/
      DATA AEXP3A(4)/  0.70542 39219 11838        D   -5/
      DATA AEXP3A(5)/ -0.66717 27454 7611         D   -6/
      DATA AEXP3A(6)/  0.72426 75899 824          D   -7/
      DATA AEXP3A(7)/ -0.87825 82560 56           D   -8/
      DATA AEXP3A(8)/  0.11672 23442 78           D   -8/
      DATA AEXP3A(9)/ -0.16766 31281 2            D   -9/
      DATA AEXP3A(10)/ 0.25755 01577              D  -10/
      DATA AEXP3A(11)/-0.41957 8881               D  -11/
      DATA AEXP3A(12)/ 0.72010 412                D  -12/
      DATA AEXP3A(13)/-0.12949 055                D  -12/
      DATA AEXP3A(14)/ 0.24287 03                 D  -13/
      DATA AEXP3A(15)/-0.47331 1                  D  -14/
      DATA AEXP3A(16)/ 0.95531                    D  -15/
      DATA AEXP3A(17)/-0.19914                    D  -15/
      DATA AEXP3A(18)/ 0.4277                     D  -16/
      DATA AEXP3A(19)/-0.944                      D  -17/
      DATA AEXP3A(20)/ 0.214                      D  -17/
      DATA AEXP3A(21)/-0.50                       D  -18/
      DATA AEXP3A(22)/ 0.12                       D  -18/
      DATA AEXP3A(23)/-0.3                        D  -19/
      DATA AEXP3A(24)/ 0.1                        D  -19/
C
C   Start calculation
C
      X = XVALUE
C
C   Error test
C
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         EXP3 = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM EXP3--ARGUMENT MUST BE ',
     1       'NON-NEGATIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      T = D1MACH(3)
      XLOW = ( FOUR * T ) ** (ONE/THREE)
      XUPPER = ( -LOG ( T ) ) ** (ONE/THREE)
      T = T / ONEHUN
      IF ( X .LE. TWO ) THEN
         DO 10 NTERM1 = 24 , 0 , -1
            IF ( ABS(AEXP3(NTERM1)) .GT. T ) GOTO 19
 10      CONTINUE
 19      CONTINUE
      ELSE
         DO 40 NTERM2 = 24 , 0 , -1
            IF ( ABS(AEXP3A(NTERM2)) .GT. T ) GOTO 49
 40      CONTINUE
 49   ENDIF
C
C   Code for XVALUE < =  2
C
      IF ( X .LE. TWO ) THEN
         IF ( X .LT. XLOW ) THEN
            EXP3 = X
         ELSE
            T =  (  ( X * X * X / FOUR ) - HALF ) - HALF
            EXP3 = X * CHEVAL ( NTERM1,AEXP3,T ) 
         ENDIF
      ELSE
C
C   Code for XVALUE > 2
C
         IF ( X .GT. XUPPER ) THEN
            EXP3 = FUNINF
         ELSE
            T = ( ( SIXTEN/ ( X * X * X ) ) - HALF ) - HALF
            T = CHEVAL ( NTERM2,AEXP3A,T ) 
            T = T * EXP ( -X * X * X ) / ( THREE * X * X ) 
            EXP3 = FUNINF - T
         ENDIF
      ENDIF
      RETURN
      END            
      SUBROUTINE EXPLOS(X,N,ENGLSL,ENGUSL,COSUSL,IWRITE,XEL,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE EXPECTED LOSS FROM THE DATA IN THE INPUT VECTOR X.
C              THIS CALCULATION ASSUMES--
C                 1) A QUADRATIC LOSS FUNCTION
C                 2) A NORMAL DISTRIBUTION
C                 3) WITH MEAN XBAR AND STANDARD DEVIATION S
C                 4) A DOLLAR COST    COSUSL   AT THE UPPER SPEC LIMIT
C                 5) THE TARGET IS MIDWAY BETWEEN ENGUSL AND ENGLSL
C              XEL = INTEGRAL K*(X-TARGET)**2 * NORMALPDF(XBAR,S)
C              WHERE K IS DERIVED FROM THE LOSS FUNCTION
C                 L(X) = K*(X-TARGET)**2
C              EVALUATED AT X = USL
C                 SOLVING     L(USL) = COSUSL
C                             K*(USL-TARGET)**2 = COSUSL
C                             K = COSUSL / (USL-TARGET)**2
C     THE FINAL FORM FOR XEL IS QUITE SIMPLE--
C        XEL = COSUSL * (KSIGMA**2 + KMU**2)
C     WHERE KSIGMA IS DEFINED VIA   SIGMA = KSIGMA * H
C     AND   KMU    IS DEFINED VIA   MU    = TARGET + KMU*H
C     YIELDING KSIGMA = SIGMA / H
C     AND      KMU    = (MU - TARGET) / H
C     IN PRACTICE, WE USE XBAR FOR MU AND S FOR SIGMA.
C     NOTE--XEL IS A MEASURE OF PROCESS COST AND IS
C           SENSITIVE TO LOSS FROM BOTH BIAS AND FROM VARIATION.
C     NOTE--XEL IS A MEASURE WHICH TAKES ON
C           THE VALUES 0 TO INFINITY.
C           A GOOD PROCESS YIELDS VALUES OF
C           EXPECTED LOSS NEAR 0.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C                     --ENGLSL = LOWER (ENGINEERING) SPEC LIMIT
C                     --ENGUSL = UPPER (ENGINEERING) SPEC LIMIT
C                     --COSUSL = COST AT UPPER SPEC LIMIT
C     OUTPUT ARGUMENTS--EXPLOS = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE EXPECTED LOSS
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE EXPECTED LOSS (IN XEL)
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--R&M 2000 AIR FORCE MANUAL
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89.5
C     ORIGINAL VERSION--MAY       1989.
C     UPDATED         --SEPTEMBER 1990. REVERSE INPUT ARGS
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DVAR
      DOUBLE PRECISION DSD
C
      DOUBLE PRECISION DUSL
      DOUBLE PRECISION DLSL
C
      DOUBLE PRECISION DTARG
      DOUBLE PRECISION DH
      DOUBLE PRECISION DKMU
      DOUBLE PRECISION DKSIGM
      DOUBLE PRECISION DEL
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='EXPL'
      ISUBN2='OS  '
C
      IERROR='NO'
C
      DMEAN=0.0D0
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF EXPLOS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)ENGUSL,ENGLSL,COSUSL
   54 FORMAT('ENGUSL,ENGLSL,COSUSL = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               ********************************************
C               **  COMPUTE PROCESS CAPABILITY INDEX EXPLOS  **
C               ********************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.GE.1)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN EXPLOS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      THE EXPECTED LOSS IS TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,121)
CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN EXPLOS--',
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1')
      XSD=0.0
      GOTO9000
  129 CONTINUE
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,136)HOLD
CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN EXPLOS--',
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      XSD=0.0
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               ***************************************
C               **  STEP 2--                         **
C               **  COMPUTE THE STANDARD DEVIATION.  **
C               ***************************************
C
      DN=N
      DSUM=0.0D0
      DO200I=1,N
      DX=X(I)
      DSUM=DSUM+DX
  200 CONTINUE
      DMEAN=DSUM/DN
C
      DSUM=0.0D0
      DO300I=1,N
      DX=X(I)
      DSUM=DSUM+(DX-DMEAN)**2
  300 CONTINUE
      DVAR=DSUM/(DN-1.0D0)
      DSD=0.0D0
      IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR)
      XSD=DSD
C
C               **************************************************
C               **  STEP 3--                                    **
C               **  COMPUTE THE EXPECTED LOSS                   **
C               **************************************************
C
      DUSL=ENGUSL
      DLSL=ENGLSL
C
      DTARG=(DUSL+DLSL)/2.0D0
      DH=(DUSL-DLSL)/2.0D0
C
      IF(DH.EQ.0.0D0)XEL=CPUMAX
      IF(DH.EQ.0.0D0)GOTO490
C
      DKSIGM=DSD/DH
      DKMU=(DMEAN-DTARG)/DH
C
      DCOSUS=COSUSL
      DEL=DCOSUS*(DKSIGM**2+DKMU**2)
      XEL=DEL
C
  490 CONTINUE
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)N,XEL
  811 FORMAT('THE EXPECTED LOSS ($) OF THE ',I8,' OBSERVATIONS = ',
     1E15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF EXPLOS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)DMEAN
 9014 FORMAT('DMEAN = ',D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)DSD
 9015 FORMAT('DSD = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)DUSL,DLSL,DTARG,DH
 9016 FORMAT('DUSL,DLSL,DTARG,DH = ',4D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)DKMU,DKSIGM,DEL,XEL
 9017 FORMAT('DKMU,DKSIGM,DEL,XEL = ',3D15.7,E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE EXPAFR(X1,X2,SCALE,AFR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE AVERAGE FAILURE
C              RATE (AFR) FUNCTION VALUE FOR THE EXPONENTIAL DISTRIBUTION.
C              THE AFR IS DEFINED AS:
C
C              AFR(X1,X2,LOC,SCALE) = (H(X2,LOC,SCALE) - H(X1,LOC,SCALE))/(X2-X1)
C
C              WHERE
C
C              H(X,LOC,SCALE) = (X-LOC)/SCALE
C
C              SO
C
C              AFR(X1,X2) = ((X2-LOC)/SCALE) - (X1-LOC)/SCALE)/(X2-X1)
C                         = 1/SCALE
C
C              NOTE THAT THE LOCATION PARAMETER CANCELS OUT, SO
C              WE OMIT THE ARGUMENT.
C     INPUT  ARGUMENTS--X1     = THE SINGLE PRECISION VALUE AT
C                                WHICH THE AFR FUNCTION IS TO BE
C                                EVALUATED.
C     INPUT  ARGUMENTS--X2     = THE SINGLE PRECISION VALUE AT
C                                WHICH THE AFR FUNCTION IS TO BE
C                                EVALUATED.
C     OUTPUT ARGUMENTS--AFR    = THE SINGLE PRECISION AVERAGE
C                                FAILURE RATE FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION AVERAGE FAILURE RATE
C             FUNCTION VALUE PDF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X2 AND X1  SHOULD BE NON-NEGATIVE AND NOT EQUAL.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--TOBIAS AND TRINDALE, "APPLIED RELIABILITY", SECOND
C                 EDITION, CHAPMAN AND HALL/CRC, 1995.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 INFORMATION TECHNOLOGY LABORATORY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--MARCH     2005. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 ICOUTINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,ICOUTINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      X1MN=MIN(X1,X2)
      X1MX=MAX(X1,X2)
      IF(X1MN.EQ.X1MX)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)X1MN
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)X1MX
        CALL DPWRST('XXX','BUG ')
        AFR=0.0
        GOTO9000
      ELSEIF(X1MN.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X1MN
        CALL DPWRST('XXX','BUG ')
        AFR=0.0
        GOTO9000
      ELSEIF(SCALE.LE.0.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)SCALE
        CALL DPWRST('XXX','BUG ')
        AFR=0.0
        GOTO9000
      ENDIF
   90 CONTINUE
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO EXPAFR ',
     1       'IS NEGATIVE')
    5 FORMAT('***** ERROR--THE FIRST AND SECOND INPUT ARGUMENTS ',
     1       'TO EXPAFR ARE EQUAL')
    6 FORMAT('***** ERROR--THE FOURTH INPUT ARGUMENT TO EXPAFR ',
     1       '(THE SCALE) IS NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8)
   47 FORMAT('***** THE VALUE OF THE FIRST ARGUMENT IS ',E15.8)
   48 FORMAT('***** THE VALUE OF THE SECOND ARGUMENT IS ',E15.8)
C
C-----START POINT-----------------------------------------------------
C
      AFR=1.0/SCALE
C
 9000 CONTINUE
      RETURN
      END 
      SUBROUTINE EXPCDF(X,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE EXPONENTIAL DISTRIBUTION
C              WITH MEAN = 1 AND STANDARD DEVIATION = 1.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(-X).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 207-232.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT TO')
    5 FORMAT('      THE EXPCDF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CDF=1.0-EXP(-X)
C
      RETURN
      END 
      SUBROUTINE EXPCHA(X,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE EXPONENTIAL DISTRIBUTION
C              WITH MEAN = 1 AND STANDARD DEVIATION = 1.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(-X) AND
C              CUMULATIVE HAZARD FUNCTION
C              H(X)=X.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION
C                                CUMULATIVE HAZARD FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD
C             FUNCTION VALUE PDF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, CHAPTER 19.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1998. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 ICOUTINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,ICOUTINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      HAZ=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE EXPHAZ SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      HAZ=X
C
      RETURN
      END 
      DOUBLE PRECISION FUNCTION EXPFUN (DA)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDECE INTERVAL FOR THE 1-SAMPLE EXPONENTIAL
C              MODEL WITH TIME CENSORING.  THIS FUNCTION FINDS THE ROOT
C              OF THE EQUATION:
C
C                 2*IR*LN(SIGMAHAT) - (2/SIGMAHAT)*2*SUM[i=1 to N][X(i)]
C                 + 2*IR*LN(A) + (2/A)*SUM[i=1 to N][X(i)] - K
C
C              WITH
C
C                 IR       = NUMBER OF FAILURE TIMES
C                 SIGMAHAT = POINT ESTIMATE OF SIGMA
C                 A        = PARAMETER OF INTEREST
C                 K        = CHSPPF(ALPHA,1)
C
C              NOTE THAT THE SUM[X(I)], K, IR ARE COMPUTED IN
C              DPMLE2 AND PASSED VIA COMMON BLOCK.
C
C              CALLED BY DFZERO ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.
C     EXAMPLE--EXPONENTIAL MAXIMUM LIKELIHOOD Y CENSOR
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 12 (SEE
C                EXAMPLE 12.3).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/10
C     ORIGINAL VERSION--OCTOBER    2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DA
C
      DOUBLE PRECISION DC
      DOUBLE PRECISION DK
      DOUBLE PRECISION DR
      DOUBLE PRECISION SHAT
      DOUBLE PRECISION XSUM
      COMMON/EXPCOM/DK,DR,SHAT,XSUM,DC
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      EXPFUN=DC - 2.0D0*(-DR*DLOG(DA) - XSUM/DA) - DK
C
      RETURN
      END
      REAL FUNCTION EXPFU2 (SIGHAT,X,N)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE MAXIMUM LIKELIHOOD
C              ESTIMATE OF SIGMA FOR THE 1-PARAMETER EXPONENTIAL
C              MODEL FOR GROUPED DATA (NO CENSORING).  THIS FUNCTION
C              FINDS THE ROOT OF THE EQUATION:
C
C                 SUM[i=1 to k-1][N(i)*(X(i)-X(i-1))/
C                     (EXP(X(i)-X(I-1))/SIGMAHAT) - 1) -
C                 SUM[I=2 to k][N(i)*X(i-1)] = 0
C
C              WITH
C
C                 X(i)     = UPPER BOUNDARY OF iTH BIN
C                 N(i)     = COUNT FOR iTH INTERVAL
C                 SIGMAHAT = POINT ESTIMATE OF SIGMA (THIS IS THE
C                            PARAMETER WE ARE ITERATING OVER)
C                 K        = NUMBER OF INTERVALS
C
C              FORMULAS GO FROM 0 TO K.  FOR CONVENIENCE WITH
C              FORTRAN, WE WILL GO FROM 1 TO K+1.
C
C              CALLED BY FZEROY ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.
C     EXAMPLE--EXPONENTIAL GROUPED MAXIMUM LIKELIHOOD Y X
C     REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                UNIVARIATE DISTRIBUTIONS--Volume 1", SECOND EDITION,
C                WILEY, 1994, PP. 509-510.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/10
C     ORIGINAL VERSION--OCTOBER    2004.
C
C---------------------------------------------------------------------
C
      REAL SIGHAT
      REAL X(*)
      REAL N(*)
C
      INTEGER IK
      COMMON/EX2COM/IK
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DNI
      DOUBLE PRECISION DX1
      DOUBLE PRECISION DX2
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      DSUM1=0.0D0
      DSUM2=0.0D0
C
C  COMPUTE SUM FOR FIRST TERM
C
      DO100I=2,IK
        DNI=DBLE(N(I))
        DX1=DBLE(X(I))
        DX2=DBLE(X(I-1))
        DTERM1=DNI*(DX1-DX2)/(DEXP((DX1-DX2)/DBLE(SIGHAT))-1.0D0)
        DSUM1=DSUM1 + DTERM1
  100 CONTINUE
C
C  COMPUTE SUM FOR SECOND TERM
C
      DO200I=3,IK+1
        DNI=DBLE(N(I))
        DX2=DBLE(X(I-1))
        DSUM2=DSUM2 + DNI*DX2
  200 CONTINUE
C
      EXPFU2=REAL(DSUM1-DSUM2)
C
      RETURN
      END
      SUBROUTINE EXPHAZ(X,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE EXPONENTIAL DISTRIBUTION
C              WITH MEAN = 1 AND STANDARD DEVIATION = 1.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(-X) AND
C              HAZARD FUNCTION
C              H(X)=1.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION
C                                HAZARD FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION HAZARD
C             FUNCTION VALUE PDF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, CHAPTER 19.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1998. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 ICOUTINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,ICOUTINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      HAZ=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE EXPHAZ SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      HAZ=1.0
C
      RETURN
      END 
      SUBROUTINE EXPPDF(X,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE EXPONENTIAL DISTRIBUTION
C              WITH MEAN = 1 AND STANDARD DEVIATION = 1.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(-X).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 207-232.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 ICOUTINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,ICOUTINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      PDF=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE EXPPDF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      PDF=EXP(-X)
C
      RETURN
      END 
      SUBROUTINE EXPPPF(P,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE EXPONENTIAL DISTRIBUTION
C              WITH MEAN = 1 AND STANDARD DEVIATION = 1.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(-X).
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGES 21-44, 229-231.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 207-232.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GE.1.0)GOTO50
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST  INPUT ARGUMENT TO THE ',
     1'EXPPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      PPF=-ALOG(1.0-P)
C
      RETURN
      END
      SUBROUTINE EXPRAN(N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE EXPONENTIAL DISTRIBUTION
C              WITH MEAN = 1 AND STANDARD DEVIATION = 1.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(-X).
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE EXPONENTIAL DISTRIBUTION
C             WITH MEAN = 1 AND STANDARD DEVIATION = 1.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 14, 35-36.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 207-232.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 58.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --JULY      1976.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'EXPRAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N EXPONENTIAL RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
      X(I)=-ALOG(X(I))
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE EXPSF(P,SF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SPARSITY
C              FUNCTION VALUE FOR THE EXPONENTIAL DISTRIBUTION
C              WITH MEAN = 1 AND STANDARD DEVIATION = 1.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(-X).
C              NOTE THAT THE SPARSITY FUNCTION OF A DISTRIBUTION
C              IS THE DERIVATIVE OF THE PERCENT POINT FUNCTION,
C              AND ALSO IS THE RECICOUTOCAL OF THE PROBABILITY
C              DENSITY FUNCTION (BUT IN UNITS OF P RATHER THAN X).
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE 
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE SPARSITY
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--SF     = THE SINGLE PRECISION
C                                SPARSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION SPARSITY
C             FUNCTION VALUE SF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGES 21-44, 229-231.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 207-232.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 ICOUTINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,ICOUTINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GE.1.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE FIRST  INPUT ARGUMENT TO THE')
    2 FORMAT('      SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      SF=1.0/(1.0-P)
C
      RETURN
      END 
      SUBROUTINE EXPSMO(X,TEMP,ALPHA,AMSE,NX,IWRITE,Y,IBUGA3,IERROR)
C
C     PURPOSE--COMPUTE EXPONETIAL SMOOTH OF AN ARRAY
C              THE ALPHA PARANETER IDENTIFIES THE SMOOTHING PARAMETER
C     NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.)
C           BEING IDENTICAL TO THE INPUT VECTOR X(.).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98/5
C     ORIGINAL VERSION--MAY       1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
      DOUBLE PRECISION DSUM
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION TEMP(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='EXPS'
      ISUBN2='MO  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF EXPSMO--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NX,ALPHA
   53 FORMAT('NX,ALPHA = ',I8,1X,F10.5)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NX
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               **************************************
C               **  COMPUTE EXPONENTIAL SMOOTH      **
C               **************************************
C
      IF(ALPHA.LE.0.0 .OR. ALPHA.GE.1.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,101)
  101   FORMAT('***** ERROR FROM EXPSMO.  SMOOTHING PARAMETER MUST')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)
  103   FORMAT('      BE > 0 AND < 1.  THE ENTERED VALUE WAS ',E15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      DSUM=0.0D0
      TEMP(1)=X(1)
      DO200I=2,NX
        ATEMP=X(I)-TEMP(I-1)
        TEMP(I)=ALPHA*ATEMP + TEMP(I-1)
        DSUM=DSUM + DBLE(ATEMP)**2
  200 CONTINUE
      AMSE=REAL(DSUM)/REAL(NX-1)
C
      DO300I=1,NX
        Y(I)=TEMP(I)
  300 CONTINUE
C
      NY=NX
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF EXPSMO--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)NX,NY
 9013 FORMAT('NX,NY = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NX
      WRITE(ICOUT,9016)I,X(I),Y(I)
 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE EXPSM2(X,TEMP,ALPHA,AMSE,NX,IWRITE,Y,IBUGA3,IERROR)
C
C     PURPOSE--COMPUTE EXPONETIAL SMOOTH OF AN ARRAY
C              THE ALPHA PARANETER IDENTIFIES THE SMOOTHING PARAMETER
C              NOTE: USE THIS VERSION IF ALPHA NOT SPECIFIED.
C                    USE AN ITERATIVE SEARCH TO FIND THE OPTIMAL
C                    VALUE FOR ALPHA.
C     NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.)
C           BEING IDENTICAL TO THE INPUT VECTOR X(.).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--99/2
C     ORIGINAL VERSION--FEBRUARY  1999.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION TEMP(*)
C
      REAL AMSEV(20)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='EXPS'
      ISUBN2='MO  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF EXPSM2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NX,ALPHA
   53 FORMAT('NX,ALPHA = ',I8,1X,F10.5)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NX
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               **************************************
C               **  COMPUTE EXPONENTIAL SMOOTH      **
C               **************************************
C
CCCCC FIND BEST ALPHA TO FIRST DECIMAL PLACE.
C
      AMNVAL=CPUMAX
      DO100I=1,9
        ALPHA=REAL(I)/10.
        CALL EXPSMO(X,TEMP,ALPHA,AMSE,NX,IWRITE,Y,IBUGA3,IERROR)
        AMSEV(I)=AMSE
        IF(AMSEV(I).LT.AMNVAL)THEN
          AX=ALPHA
          AMNVAL=AMSEV(I)
        ENDIF
  100 CONTINUE
      ALPHA=AX
C
CCCCC FIND BEST ALPHA TO FIRST DECIMAL PLACE.
C
      AMNVAL=CPUMAX
      D=0.09
      DINC=0.01
      ASTRT=ALPHA-D
      DO200I=1,19
        ALPHA=ASTRT+REAL(I-1)*DINC
        CALL EXPSMO(X,TEMP,ALPHA,AMSE,NX,IWRITE,Y,IBUGA3,IERROR)
        AMSEV(I)=AMSE
        IF(AMSEV(I).LT.AMNVAL)THEN
          AX=ALPHA
          AMNVAL=AMSEV(I)
        ENDIF
  200 CONTINUE 
      ALPHA=AX
C
CCCCC FIND BEST ALPHA TO THIRD DECIMAL PLACE.
C
      AMNVAL=CPUMAX
      D=0.009
      DINC=0.001
      ASTRT=ALPHA-D
      DO300I=1,19
        ALPHA=ASTRT+REAL(I-1)*DINC
        CALL EXPSMO(X,TEMP,ALPHA,AMSE,NX,IWRITE,Y,IBUGA3,IERROR)
        AMSEV(I)=AMSE
        IF(AMSEV(I).LT.AMNVAL)THEN
          AX=ALPHA
          AMNVAL=AMSEV(I)
        ENDIF
  300 CONTINUE 
      ALPHA=AX
C
      IF(IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,510)ALPHA
  510   FORMAT('FOR EXPONENTIAL SMOOTHING, OPTIMAL VALUE OF ALPHA',
     1         '(TO 3 DECIMAL PLACES) = ',F5.3)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF EXPSM2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)NX
 9013 FORMAT('NX = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NX
      WRITE(ICOUT,9016)I,X(I),Y(I)
 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE EXTDIG(IINPUT,IDIGIT,NDIGIT,IBUGA3,IERROR)
C
C     PURPOSE--EXTRACT THE DIGITS FROM AN INTEGER.
C              PROCEED LEFT TO RIGHT.
C     INPUT  ARGUMENTS--  IINPUT = AN INTEGER
C     OUTPUT ARGUMENTS--  IDIGIT   = VECTOR OF DIGITS
C                         NDIGIT   = NUMBER OF ELEMENTS IN IDIGIT
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--89.1
C     ORIGINAL VERSION--JANUARY   1989.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
      DIMENSION IDIGIT(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IERROR='NO'
      NDIGIT=0
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF EXTDIG--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IINPUT
   52 FORMAT('IINPUT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IBUGA3
   53 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               **************************************************
C               **  STEP 11--                                   **
C               **  CHECK THE INPUT NUMBER FOR ERRORS           **
C               **************************************************
C
      IF(IINPUT.GE.0)GOTO1190
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1111)
 1111 FORMAT('***** ERROR IN EXTDIG--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1112)
 1112 FORMAT('      THE INPUT NUMBER WAS NEGATIVE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1113)IINPUT
 1113 FORMAT('      THE INPUT NUMBER = ',I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 1190 CONTINUE
C
C               **************************************************
C               **  STEP 12--                                   **
C               **  DETERMINE THE NUMBER OF DIGITS              **
C               **  IN THE NUMBER                               **
C               **************************************************
C
      MAXDIG=9
      IREM=IINPUT
      DO1200I=1,MAXDIG
      IREV=MAXDIG-I+1
      IPOWER=INT(10.0**IREV + 0.01)
      IRATIO=IREM/IPOWER
      IF(IRATIO.EQ.0)GOTO1200
      GOTO1290
 1200 CONTINUE
      IREV=0
 1290 CONTINUE
      NDIGIT=IREV+1
C
C               **************************************************
C               **  STEP 13--                                   **
C               **  EXTRACT THE INDIVIDUAL DIGITS               **
C               **************************************************
C
      IREM=IINPUT
      J=0
      DO1300I=1,NDIGIT
      J=J+1
      IREV=NDIGIT-I+1
      IPOWER=INT(10**(IREV-1) + 0.01)
      IDIGIT(I)=IREM/IPOWER
      IREM=IREM-IDIGIT(I)*IPOWER
 1300 CONTINUE
C
C               *******************
C               **   STEP 90--   **
C               **   EXIT        **
C               *******************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF EXTDIG--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IINPUT
 9012 FORMAT('IINPUT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IBUGA3,IERROR
 9013 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)NDIGIT
 9021 FORMAT('NDIGIT = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NDIGIT.LE.0)GOTO9024
      DO9022I=1,NDIGIT
      WRITE(ICOUT,9023)I,IDIGIT(I)
 9023 FORMAT('I,IDIGIT(I) = ',2I8)
      CALL DPWRST('XXX','BUG ')
 9022 CONTINUE
 9024 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE EXTSTR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXIND,
     1IHNAME,IHNAM2,IUSE,NUMNAM,
     1ISTRN1,ISTRN2,NUMSTR,
     1IWRITE,IBUGA2,ISUBRO,IERROR)
C
C     PURPOSE--EXAMINE IHARG(.) AND IHARG2(.) FROM JMIN TO JMAX,
C              EXTRACT ALL NAMES
C              (INCLUDING THOSE IMPLIED BY A   TO   KEYWORD)
C              AND PLACE THESE NAMES IN ISTRN1(.) AND ISTRN2(.).
C              NOTE THE NUMBER OF SUCH NAMES AND PLACE IT IN NUMSTR.
C              NUMSTR STANDS FOR NUMBER OF STRINGS.
C     NOTE--JMIN   = START POINT IN IHARG/IHARG2 FOR THE SCAN
C           JMAX   = STOP POINT  IN IHARG/IHARG2 FOR THE SCAN
C           MAXIND = MAXIMUM PERMITTED NUMBER OF STRINGS
C     NOTE--THIS SUBROUTINE ALSO CHECKS TO MAKE SURE THE
C           LIST ITEMS ARE IN FACT STRINGS (AS OPPOSED
C           TO PARAMETERS, VARIABLES, MATRICES, OR
C           UNKNOWNS).
C     OUTPUT--ISTRN1(.), ISTRN2(.), AND NUMSTR.
C     ORIGINAL VERSION--JANUARY   2006.
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION IHARG2(*)
      DIMENSION IHNAME(*)
      DIMENSION IHNAM2(*)
      DIMENSION IUSE(*)
      DIMENSION ISTRN1(*)
      DIMENSION ISTRN2(*)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IHARG2
      CHARACTER*4 IHNAME
      CHARACTER*4 IHNAM2
      CHARACTER*4 IUSE
      CHARACTER*4 ISTRN1
      CHARACTER*4 ISTRN2
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA2
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 IH1
      CHARACTER*4 IH2
      CHARACTER*4 ICASTO
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      NUMSTR=0
C
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TSTR')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF EXTSTR--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)IBUGA2,ISUBRO
   53   FORMAT('IBUGA2,ISUBRO = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,54)JMIN,JMAX,MAXIND,NUMSTR
   54   FORMAT('JMIN,JMAX,MAXIND,NUMSTR = ',4I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,61)NUMARG
   61   FORMAT('NUMARG = ',A4)
        CALL DPWRST('XXX','BUG ')
        DO62I=1,NUMARG
          WRITE(ICOUT,63)I,IHARG(I),IHARG2(I)
   63     FORMAT('I,IHARG(I),IHARG2(I) = ',I8,2X,A4,2X,A4)
          CALL DPWRST('XXX','BUG ')
   62   CONTINUE
        WRITE(ICOUT,71)NUMNAM
   71   FORMAT('NUMNAM = ',I8)
        CALL DPWRST('XXX','BUG ')
        DO72I=1,NUMNAM
          WRITE(ICOUT,73)I,IHNAME(I),IHNAM2(I),IUSE(I)
   73     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I) = ',
     1           I8,2X,A4,A4,2X,A4,I8,I8,E15.7)
        CALL DPWRST('XXX','BUG ')
   72   CONTINUE
      ENDIF
C
      DO1200J=JMIN,JMAX
        IH1=IHARG(J)
        IH2=IHARG2(J)
        ICASTO='OFF'
C
        IF(IH1.EQ.'TO  ')THEN
          ICASTO='ON'
          JM1=J-1
          JP1=J+1
          CALL DPEXTL(IHARG(JM1),IHARG2(JM1),IHARG(JP1),IHARG2(JP1),
     1                KNUMB,IVAL1,IVAL2,IBUGA2,ISUBRO,IERROR)
C
          IVA1P1=IVAL1+1
          IVA2M1=IVAL2-1
          IF(IVA1P1.GT.IVA2M1)GOTO1200
          IVAL=IVAL1
          IVAL=IVAL+1
          IF(IVAL.GE.IVAL2)GOTO1200
          CALL DPAPNU(IHARG(JM1),IHARG2(JM1),KNUMB,IVAL,
     1                IH1,IH2,IBUGA2,ISUBRO,IERROR)
        ENDIF
C
 1215   CONTINUE
C
        DO1300I=1,NUMNAM
          I2=I
          IF(IH1.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I))THEN
            IF(IUSE(I).EQ.'V')GOTO1320
            IF(IUSE(I).EQ.'P')GOTO1320
            IF(IUSE(I).EQ.'M')GOTO1320
            IF(IUSE(I).EQ.'F')GOTO1310
          ENDIF
 1300   CONTINUE
        GOTO1320
C
 1310   CONTINUE
        NUMSTR=NUMSTR+1
        IF(NUMSTR.GT.MAXIND)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1331)
 1331     FORMAT('***** ERROR IN EXTSTR--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1332)
 1332     FORMAT('      THE NUMBER OF STRINGS PERMITTED HAS JUST')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1334)MAXIND
 1334     FORMAT('      EXCEEDED THE ALLOWABLE MAXIMUM (',I8,')')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1336)IH1,IH2
 1336     FORMAT('      THE STRING IN QUESTION WAS ',2A4,'   .')
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
          GOTO9000
        ENDIF
        ISTRN1(NUMSTR)=IH1
        ISTRN2(NUMSTR)=IH2
        GOTO1280
C
 1320   CONTINUE
        IF(IWRITE.EQ.'ON')THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1311)
 1311     FORMAT('***** ERROR IN EXTSTR--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1312)
 1312     FORMAT('      A NAME IN THE LIST OF STRINGS INCLUDED THE ',
     1           'NAME OF A')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1315)
 1315     FORMAT('      NON-EXISTENT STRING OR A NON-STRING.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1316)IH1,IH2
 1316     FORMAT('      THE NAME IN QUESTION WAS ',2A4,'   .')
          CALL DPWRST('XXX','BUG ')
        ENDIF
        IERROR='YES'
        GOTO9000
C
 1280   CONTINUE
        IF(ICASTO.EQ.'ON')THEN
          IVAL=IVAL+1
          IF(IVAL.GE.IVAL2)GOTO1200
          CALL DPAPNU(IHARG(JM1),IHARG2(JM1),KNUMB,IVAL,
     1                IH1,IH2,IBUGA2,ISUBRO,IERROR)
          GOTO1215
        ENDIF
C
 1200 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'TSTR')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF EXTSTR--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)IBUGA2,ISUBRO
 9013   FORMAT('IBUGA2,ISUBRO = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9014)JMIN,JMAX,NUMSTR
 9014   FORMAT('JMIN,JMAX,NUMSTR = ',3I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9021)NUMARG
 9021   FORMAT('NUMARG = ',A4)
        CALL DPWRST('XXX','BUG ')
        DO9022I=1,NUMARG
          WRITE(ICOUT,9023)I,IHARG(I),IHARG2(I)
 9023     FORMAT('I,IHARG(I),IHARG2(I) = ',I8,2X,A4,2X,A4)
          CALL DPWRST('XXX','BUG ')
 9022   CONTINUE
        WRITE(ICOUT,9031)NUMNAM
 9031   FORMAT('NUMNAM = ',I8)
        CALL DPWRST('XXX','BUG ')
        DO9032I=1,NUMNAM
          WRITE(ICOUT,9033)I,IHNAME(I),IHNAM2(I),IUSE(I)
          CALL DPWRST('XXX','BUG ')
 9033     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I) = ',
     1           I8,2X,A4,A4,2X,A4,I8,I8,E15.7)
 9032   CONTINUE
        WRITE(ICOUT,9041)NUMSTR
 9041   FORMAT('NUMSTR = ',I8)
        CALL DPWRST('XXX','BUG ')
        DO9042I=1,NUMSTR
          WRITE(ICOUT,9043)I,ISTRN1(I),ISTRN2(I)
 9043     FORMAT('I,ISTRN1(I),ISTRN2(I) = ',I8,2X,A4,2X,A4)
          CALL DPWRST('XXX','BUG ')
 9042   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE EXTVAR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXIND,
     1IHNAME,IHNAM2,IUSE,NUMNAM,
     1IVARN1,IVARN2,NUMIND,IBUGA2,ISUBRO,IERROR)
C
C     PURPOSE--EXAMINE IHARG(.) AND IHARG2(.) FROM JMIN TO JMAX,
C              EXTRACT ALL NAMES
C              (INCLUDING THOSE IMPLIED BY A   TO   KEYWORD)
C              AND PLACE THESE NAMES IN IVARN1(.) AND IVARN2(.).
C              NOTE THE NUMBER OF SUCH NAMES AND PLACE IT IN NUMIND.
C              NUMIND STANDS FOR NUMBER OF INDEPENDENT VARIABLES
C              (NOT INCLUDING THE IMPLICIT UNITY VARIABLE).
C     NOTE--JMIN   = START POINT IN IHARG/IHARG2 FOR THE SCAN
C           JMAX   = STOP POINT  IN IHARG/IHARG2 FOR THE SCAN
C           MAXIND = MAXIMUM PERMITTED NUMBER OF VARIABLES
C     NOTE--THIS SUBROUTINE IS USED IN CONJUNCTION
C           WITH THE MULTI-LINEAR OPTION OF THE FIT COMMAND;
C           IT IS CALLED BY DPFIT.
C     NOTE--THIS SUBROUTINE ALSO CHECKS TO MAKE SURE THE
C           LIST ITEMS ARE IN FACT VARIABLES (AS OPPOSED
C           TO PARAMETERS, FUNCTIONS, MATRICES, OR
C           UNKNOWNS).
C     OUTPUT--IVARN1(.), IVARN2(.), AND NUMIND.
C     EXAMPLE--FIT Y X1 X2 X3
C              WOULD YIELD NUMIND = 3
C     EXAMPLE--FIT Y X1 TO X15
C              WOULD YIELD NUMIND = 15
C     EXAMPLE--FIT Y R1 R2 X5 TO X11 Z1 Z2
C              WOULD YIELD NUMIND = 11
C     ORIGINAL VERSION--JUNE      1989.
C     UPDATED         --JULY      1989.  FIX FORMAT STATEMENT
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION IHARG2(*)
      DIMENSION IHNAME(*)
      DIMENSION IHNAM2(*)
      DIMENSION IUSE(*)
      DIMENSION IVARN1(*)
      DIMENSION IVARN2(*)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IHARG2
      CHARACTER*4 IHNAME
      CHARACTER*4 IHNAM2
      CHARACTER*4 IUSE
      CHARACTER*4 IVARN1
      CHARACTER*4 IVARN2
      CHARACTER*4 IBUGA2
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 IH1
      CHARACTER*4 IH2
      CHARACTER*4 ICASTO
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      NUMIND=0
C
      IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'TVAR')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF EXTVAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IBUGA2,ISUBRO
   53 FORMAT('IBUGA2,ISUBRO = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)JMIN,JMAX,MAXIND,NUMIND
   54 FORMAT('JMIN,JMAX,MAXIND,NUMIND = ',4I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)NUMARG
   61 FORMAT('NUMARG = ',A4)
      CALL DPWRST('XXX','BUG ')
      DO62I=1,NUMARG
      WRITE(ICOUT,63)I,IHARG(I),IHARG2(I)
   63 FORMAT('I,IHARG(I),IHARG2(I) = ',I8,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   62 CONTINUE
      WRITE(ICOUT,71)NUMNAM
   71 FORMAT('NUMNAM = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO72I=1,NUMNAM
      WRITE(ICOUT,73)I,IHNAME(I),IHNAM2(I),IUSE(I)
   73 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I) = ',
     1I8,2X,A4,A4,2X,A4,I8,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   72 CONTINUE
   90 CONTINUE
C
      DO1200J=JMIN,JMAX
      IH1=IHARG(J)
      IH2=IHARG2(J)
      ICASTO='OFF'
C
      IF (IH1.EQ.'TO  ')GOTO1210
      GOTO1220
C
 1210 CONTINUE
      ICASTO='ON'
      JM1=J-1
      JP1=J+1
      CALL DPEXTL(IHARG(JM1),IHARG2(JM1),IHARG(JP1),IHARG2(JP1),
     1KNUMB,IVAL1,IVAL2,IBUGA2,ISUBRO,IERROR)
C
      IVA1P1=IVAL1+1
      IVA2M1=IVAL2-1
      IF(IVA1P1.GT.IVA2M1)GOTO1200
      IVAL=IVAL1
C
 1215 CONTINUE
      IVAL=IVAL+1
      IF(IVAL.GE.IVAL2)GOTO1200
C
      CALL DPAPNU(IHARG(JM1),IHARG2(JM1),KNUMB,IVAL,
     1IH1,IH2,IBUGA2,ISUBRO,IERROR)
      GOTO1220
C
 1220 CONTINUE
      DO1300I=1,NUMNAM
      I2=I
      IF(IH1.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I))GOTO1305
      GOTO1300
 1305 CONTINUE
      IF(IUSE(I).EQ.'V')GOTO1310
      IF(IUSE(I).EQ.'P')GOTO1320
      IF(IUSE(I).EQ.'M')GOTO1320
      IF(IUSE(I).EQ.'F')GOTO1320
 1300 CONTINUE
      GOTO1320
C
 1310 CONTINUE
      NUMIND=NUMIND+1
      IF(NUMIND.GT.MAXIND)GOTO1330
      IVARN1(NUMIND)=IH1
      IVARN2(NUMIND)=IH2
      GOTO1280
C
 1320 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1311)
 1311 FORMAT('***** ERROR IN EXTVAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1312)
 1312 FORMAT('      A NAME IN THE LIST ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1313)
 1313 FORMAT('      OF VARIABLES TO BE FIT ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1314)
 1314 FORMAT('      INCLUDED THE NAME OF A ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1315)
 1315 FORMAT('      NON-EXISTENT VARIABLE OR A NON-VARIABLE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1316)IH1,IH2
 1316 FORMAT('      THE NAME IN QUESTION WAS ',
     12A4,'   .')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1317)
 1317 FORMAT('      NO FIT WAS CARRIED OUT.')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 1330 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1331)
 1331 FORMAT('***** ERROR IN EXTVAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1332)
 1332 FORMAT('      THE NUMBER OF VARIABLES PERMITTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1333)
 1333 FORMAT('      IN A MULTI-LINEAR FIT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1334)
 1334 FORMAT('      HAS JUST EXCEEDED THE ALLOWABLE MAXIMUM')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1335)MAXIND
 1335 FORMAT('       (',I8,')')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1336)IH1,IH2
 1336 FORMAT('      THE VARIBLE IN QUESTION WAS ',
     12A4,'   .')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1337)
 1337 FORMAT('      NO FIT WAS CARRIED OUT.')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 1280 CONTINUE
      IF(ICASTO.EQ.'ON')GOTO1215
C
 1200 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'TVAR')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF EXTVAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IBUGA2,ISUBRO
 9013 FORMAT('IBUGA2,ISUBRO = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)JMIN,JMAX,NUMIND
 9014 FORMAT('JMIN,JMAX,NUMIND = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)NUMARG
 9021 FORMAT('NUMARG = ',A4)
      CALL DPWRST('XXX','BUG ')
      DO9022I=1,NUMARG
      WRITE(ICOUT,9023)I,IHARG(I),IHARG2(I)
 9023 FORMAT('I,IHARG(I),IHARG2(I) = ',I8,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9022 CONTINUE
      WRITE(ICOUT,9031)NUMNAM
 9031 FORMAT('NUMNAM = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9032I=1,NUMNAM
      WRITE(ICOUT,9033)I,IHNAME(I),IHNAM2(I),IUSE(I)
CCCCC THE FOLLOWING FORMAT STATEMENT WAS FIXED JULY 1989
      CALL DPWRST('XXX','BUG ')
C9033 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I) = ',
CCCCC1I8,2X,A4,A4,2X,A4,I8,I8,E1901.7)
 9033 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I) = ',
     1I8,2X,A4,A4,2X,A4,I8,I8,E15.7)
 9032 CONTINUE
      WRITE(ICOUT,9041)NUMIND
 9041 FORMAT('NUMIND = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9042I=1,NUMIND
      WRITE(ICOUT,9043)I,IVARN1(I),IVARN2(I)
 9043 FORMAT('I,IVARN1(I),IVARN2(I) = ',I8,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9042 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE FCACDF(X,U,SD,CDF)
C
C     NOTE--FOLDED-CAUCHY PDF IS:
C              FCAPDF(X,U,S)=(1/S)*(CAUPDF((X-U)/S)+CAUPDF((X+U)/S)))
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--96/1
C     ORIGINAL VERSION--JANUARY   1996.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)SD
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)SD
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT ',
     1'TO THE FCACDF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
  201 FORMAT('***** FATAL DIAGNOSTIC--THE THIRD  INPUT ARGUMENT ',
     1' TO THE FCACDF SUBROUTINE IS NEGATIVE *****')
C
      TERM1=(X-U)/SD
      CALL CAUCDF(TERM1,TERM2)
      TERM3=(-X-U)/SD
      CALL CAUCDF(TERM3,TERM4)
      CDF=TERM2-TERM4
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE FCAPDF(X,U,SD,PDF)
C
C     NOTE--FOLDED-CAUCHY PDF IS:
C              FCAPDF(X,U,S)=(1/S)*(CAUPDF((X-U)/S) + CAUPDF((X+U)/S)))
C           WHERE CAUPDF IS THE PDF OF THE STANDARD CAUCHY DISTRIBUTION
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--96/1
C     ORIGINAL VERSION--JANUARY   1996.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)SD
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT ',
     1'TO THE FCAPDF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
  201 FORMAT('***** FATAL DIAGNOSTIC--THE THIRD  INPUT ARGUMENT ',
     1'TO THE FCAPDF SUBROUTINE IS NON-POSITIVE *****')
C
      TERM1=(X-U)/SD
      CALL CAUPDF(TERM1,TERM2)
      TERM2=TERM2/SD
      TERM3=(X+U)/SD
      CALL CAUPDF(TERM3,TERM4)
      TERM4=TERM4/SD
      PDF=TERM2+TERM4
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE FCAPPF(P,U,SD,PPF)
C
C     PURPOSE   --PERCENT POINT FUNCTION FOR THE FOLDED CAUCHY
C                 DISTRIBUTION.  USES A BISECTION METHOD.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--96/1
C     ORIGINAL VERSION--JANUARY 1996.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DU
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DSD
      DOUBLE PRECISION DPI
      DOUBLE PRECISION DSDF
CCCCC DOUBLE PRECISION DTERM1, DTERM2
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA DPI /3.14159265358979D0/
      DATA EPSZ /0.0001/
      DATA SIGZ /1.0E-5/
      DATA ZERO /0./
      DATA MAXIT /30000/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GE.1.0)GOTO50
      IF(SD.LE.0.0)GOTO70
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   70 WRITE(ICOUT,35)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)SD
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      GOTO9999
C
    1 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1' FCAPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
   35 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1' FCAPPF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
   90 CONTINUE
C
C  IF P IS 0, PPF IS ZERO.  HANDLE THIS TRIVIAL CASE.
C
      IF(P.EQ.0.0)THEN
        PPF=0.0
        GOTO9999
      ENDIF
C
C  FIND BRACKETING INTERVAL.
C  AFTER SUCCESSFULLY FIND BRACKETING INTERVAL, THEN SWITCH TO 
C  MORE EFFICIENT BISECTION METHOD.
C
      EPS=EPSZ
      SIG=SIGZ
      DU=DBLE(U)
      DSD=DBLE(SD)
CCCCC DTERM1=DEXP(-DU**2/(2.0D0*DSD**2))
CCCCC DTERM2=DSQRT(2.D0/DPI)
CCCCC TERM3=-U/SD
CCCCC CALL CAUCDF(TERM3,TERM4)
CCCCC DMEAN=DTERM2*DSD*DTERM1 + DU*(1.D0-2.D0*DBLE(TERM4))
CCCCC DSDF=DMEAN**2 + DU*DU + DSD*DSD
      DMEAN=DU
      DSDF=DSD**2
C
      XL=SNGL(DMEAN)
      XINC=SNGL(DSDF)
      IF(XINC.LT.1.0)XINC=1.0
      ICOUNT=0
C
   91 CONTINUE
      XR=XL+XINC
      IF(XL.LE.0.0)XL=0.0
      IF(XR.LE.0.0)XR=XL+XINC
      CALL FCACDF(XL,U,SD,CDFL)
      CALL FCACDF(XR,U,SD,CDFR)
      IF(CDFL.LT.P .AND. CDFR.LT.P)THEN
        XL=XR
      ELSEIF(CDFL.GT.P .AND. CDFR.GT.P)THEN
        XL=XL-XINC
      ELSE
        GOTO99
      ENDIF
      ICOUNT=ICOUNT+1
      IF(ICOUNT.GT.MAXIT)THEN
        WRITE(ICOUT,96)
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
   96 FORMAT('***** FATAL ERROR--FCAPPF UNABLE TO FIND BRACKETING ',
     *       'INTERVAL. *****')
      GOTO91
C
C  BISECTION METHOD
C
   99 CONTINUE
      IF(XR.GT.10000.0)THEN
        EPS=0.001
        SIG=5.0E-2
      ELSEIF(XR.GT.1000.0)THEN
        EPS=0.001
        SIG=5.0E-3
      ELSEIF(XR.GT.500.0)THEN
        EPS=0.0001
        SIG=5.0E-4
      ELSEIF(XR.GT.100.0)THEN
        EPS=0.0001
        SIG=1.0E-4
      ENDIF
C
      IC = 0
      FXL = -P
      FXR = 1.0 - P
  105 CONTINUE
      X = (XL+XR)*0.5
      CALL FCACDF(X,U,SD,CDF)
      P1=CDF
      PPF=X
      FCS = P1 - P
      IF(FCS*FXL.GT.ZERO)GOTO110
      XR = X
      FXR = FCS 
      GOTO115
  110 CONTINUE
      XL = X
      FXL = FCS
  115 CONTINUE
      XRML = XR - XL
      IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999
      IC = IC + 1
      IF(IC.LE.MAXIT)GOTO105
      WRITE(ICOUT,130)
      CALL DPWRST('XXX','BUG ')
  130 FORMAT('***** WARNING--FCAPPF ROUTINE DID NOT CONVERGE. ***')
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE FCARAN(N,ALOC,ASCALE,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE FOLDED CAUCHY DISTRIBUTION.  THE FOLDED CAUCHY
C              IS THE ABSOLUTE VALUE OF A CAUCHY DISTRIBUTION.
C              GENERATE FOLDED CAUCHY RANDOM NUMBERS BY FINDING CAUCHY
C              RANDOM NUMBERS AND THEN TAKING ABSOLUTE VALUE.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALOC   = LOCATION PARAMETER OF PARENT CAUCHY
C                                DISTRIBUTION.
C                     --ASCALE = SCALE PARAMETER OF PARENT CAUCHY
C                                DISTRIBUTION.
C                     --ISEED  = SEED FOR UNIFORM RANDOM NUMBER GENERATOR
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FUNCTION VALUE FOR THE FOLDED CAUCHY DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SIN, COS.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--TOCHER, THE ART OF SIMULATION,
C                 1963, PAGE 15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGE 231.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 154-165.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2003/7
C     ORIGINAL VERSION--JULY      2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA PI/3.14159265359/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE REQUESTED NUMBER OF FOLDED CAUCHY ',
     1'RANDON NUMBERS IS NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
      IF(ASCALE.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)ASCALE
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   15 FORMAT('***** FATAL ERROR--THE SCALE PARAMETER FOR THE FOLDED ',
     1'CAUCHY RANDON NUMBERS IS NON-POSITIVE.')
   48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.7)
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N CAUCHY RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C     THEN APPLY LOCATION AND SCALE TRANSFORMATION AND TAKE ABSOLUTE VALUE.
C
      DO100I=1,N
        ARG=PI*X(I)
        X(I)=-COS(ARG)/SIN(ARG)
        X(I)=ABS(ALOC + ASCALE*X(I))
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE FCDF(X,NU1,NU2,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE F DISTRIBUTION
C              WITH INTEGER DEGREES OF FREEDOM
C              PARAMETERS = NU1 AND NU2.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X.
C              THE PROBABILITY DENSITY FUNCTION IS GIVEN
C              IN THE REFERENCES BELOW.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --NU1    = THE INTEGER DEGREES OF FREEDOM
C                                FOR THE NUMERATOR OF THE F RATIO.
C                                NU1 SHOULD BE POSITIVE.
C                     --NU2    = THE INTEGER DEGREES OF FREEDOM
C                                FOR THE DENOMINATOR OF THE F RATIO.
C                                NU2 SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE F DISTRIBUTION
C             WITH DEGREES OF FREEDOM
C             PARAMETERS = NU1 AND NU2.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --NU1 SHOULD BE A POSITIVE INTEGER VARIABLE.
C                 --NU2 SHOULD BE A POSITIVE INTEGER VARIABLE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORCDF,CHSCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DATAN.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGES 946-947,
C                 FORMULAE 26.6.4, 26.6.5, 26.6.8, AND 26.6.15.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGE 83, FORMULA 20,
C                 AND PAGE 84, THIRD FORMULA.
C               --PAULSON, AN APPROXIMATE NORMAILIZATION
C                 OF THE ANALYSIS OF VARIANCE DISTRIBUTION,
C                 ANNALS OF MATHEMATICAL STATISTICS, 1942,
C                 NUMBER 13, PAGES 233-135.
C               --SCHEFFE AND TUKEY, A FORMULA FOR SAMPLE SIZES
C                 FOR POPULATION TOLERANCE LIMITS, 1944,
C                 NUMBER 15, PAGE 217.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--AUGUST    1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --OCTOBER   1976.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX,PI,ANU1,ANU2,Z,SUM,TERM,AI,COEF1,COEF2,ARG
      DOUBLE PRECISION COEF
      DOUBLE PRECISION THETA,SINTH,COSTH,A,B
      DOUBLE PRECISION DSQRT,DATAN
      DOUBLE PRECISION DFACT1,DFACT2,DNUM,DDEN
      DOUBLE PRECISION DPOW1,DPOW2
      DOUBLE PRECISION DNU1,DNU2
      DOUBLE PRECISION TERM1,TERM2,TERM3
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA PI/3.14159265358979D0/
CCCCC DATA DPOW1,DPOW2/0.33333333333333D0,0.66666666666667D0/
C     THE FOLLOWING WAS COMMENTED OUT AND CHANGED
C     IN AUGUST OF 1986 DUE TO BOMB ON VAX
C     FOR FCDF(2,400,100)    .
C     CHANGING NUCUT2 FROM 1000 TO 250 WAS SUFFICIENT
C     TO SOLVE THE PROBLEM.
CCCCC DATA NUCUT1,NUCUT2/100,1000/
      DATA NUCUT1,NUCUT2/100,250/
C
C-----START POINT-----------------------------------------------------
C
      B=0.0
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(NU1.LE.0)GOTO50
      IF(NU2.LE.0)GOTO55
      IF(X.LT.0.0)GOTO60
      GOTO90
   50 WRITE(ICOUT,15)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)NU1
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   55 WRITE(ICOUT,23)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)NU2
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   60 WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
     1'TO THE FCDF   SUBROUTINE IS NEGATIVE *****')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'FCDF   SUBROUTINE IS NON-POSITIVE *****')
   23 FORMAT('***** FATAL ERROR--THE 3RD INPUT ARGUMENT TO THE ',
     1'FCDF   SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      DX=X
      M=NU1
      N=NU2
      ANU1=NU1
      ANU2=NU2
      DNU1=NU1
      DNU2=NU2
C
C     IF X IS NON-POSITIVE, SET CDF = 0.0 AND RETURN.
C     IF NU2 IS 5 THROUGH 9 AND X IS MORE THAN 3000
C     STANDARD DEVIATIONS BELOW THE MEAN,
C     SET CDF = 0.0 AND RETURN.
C     IF NU2 IS 10 OR LARGER AND X IS MORE THAN 150
C     STANDARD DEVIATIONS BELOW THE MEAN,
C     SET CDF = 0.0 AND RETURN.
C     IF NU2 IS 5 THROUGH 9 AND X IS MORE THAN 3000
C     STANDARD DEVIATIONS ABOVE THE MEAN,
C     SET CDF = 1.0 AND RETURN.
C     IF NU2 IS 10 OR LARGER AND X IS MORE THAN 150
C     STANDARD DEVIATIONS ABOVE THE MEAN,
C     SET CDF = 1.0 AND RETURN.
C
      IF(X.LE.0.0)GOTO105
      IF(NU2.LE.4)GOTO109
      T1=2.0/ANU1
      T2=ANU2/(ANU2-2.0)
      T3=(ANU1+ANU2-2.0)/(ANU2-4.0)
      AMEAN=T2
      SD=SQRT(T1*T2*T2*T3)
      ZRATIO=(X-AMEAN)/SD
      IF(NU2.LT.10.AND.ZRATIO.LT.-3000.0)GOTO105
      IF(NU2.GE.10.AND.ZRATIO.LT.-150.0)GOTO105
      IF(NU2.LT.10.AND.ZRATIO.GT.3000.0)GOTO107
      IF(NU2.GE.10.AND.ZRATIO.GT.150.0)GOTO107
      GOTO109
  105 CDF=0.0
      RETURN
  107 CDF=1.0
      RETURN
  109 CONTINUE
C
C     DISTINGUISH BETWEEN 6 SEPARATE REGIONS
C     OF THE (NU1,NU2) SPACE.
C     BRANCH TO THE PROPER COMPUTATIONAL METHOD
C     DEPENDING ON THE REGION.
C     NUCUT1 HAS THE VALUE 100.
C     NUCUT2 HAS THE VALUE 1000.
C
      IF(NU1.LT.NUCUT2.AND.NU2.LT.NUCUT2)GOTO1000
      IF(NU1.GE.NUCUT2.AND.NU2.GE.NUCUT2)GOTO2000
      IF(NU1.LT.NUCUT1.AND.NU2.GE.NUCUT2)GOTO3000
      IF(NU1.GE.NUCUT1.AND.NU2.GE.NUCUT2)GOTO2000
      IF(NU1.GE.NUCUT2.AND.NU2.LT.NUCUT1)GOTO5000
      IF(NU1.GE.NUCUT2.AND.NU2.GE.NUCUT1)GOTO2000
      IBRAN=5
      WRITE(ICOUT,99)IBRAN
   99 FORMAT('*****INTERNAL ERROR IN   FCDF SUBROUTINE--',
     1'IMPOSSIBLE BRANCH CONDITION AT BRANCH POINT = ',I8)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     TREAT THE CASE WHEN NU1 AND NU2
C     ARE BOTH SMALL OR MODERATE
C     (THAT IS, BOTH ARE SMALLER THAN 1000).
C     METHOD UTILIZED--EXACT FINITE SUM
C     (SEE AMS 55, PAGE 946, FORMULAE 26.6.4, 26.6.5,
C     AND 26.6.8).
C
 1000 CONTINUE
      Z=ANU2/(ANU2+ANU1*DX)
      IFLAG1=NU1-2*(NU1/2)
      IFLAG2=NU2-2*(NU2/2)
      IF(IFLAG1.EQ.0)GOTO120
      IF(IFLAG2.EQ.0)GOTO150
      GOTO250
C
C     DO THE NU1 EVEN AND NU2 EVEN OR ODD CASE
C
  120 SUM=0.0D0
      TERM=1.0D0
      IMAX=(M-2)/2
      IF(IMAX.LE.0)GOTO110
      DO100I=1,IMAX
      AI=I
      COEF1=2.0D0*(AI-1.0D0)
      COEF2=2.0D0*AI
      TERM=TERM*((ANU2+COEF1)/COEF2)*(1.0D0-Z)
      SUM=SUM+TERM
  100 CONTINUE
C
  110 SUM=SUM+1.0D0
      SUM=(Z**(ANU2/2.0D0))*SUM
      CDF=1.0D0-SUM
      RETURN
C
C     DO THE NU1 ODD AND NU2 EVEN CASE
C
  150 SUM=0.0D0
      TERM=1.0D0
      IMAX=(N-2)/2
      IF(IMAX.LE.0)GOTO210
      DO200I=1,IMAX
      AI=I
      COEF1=2.0D0*(AI-1.0D0)
      COEF2=2.0D0*AI
      TERM=TERM*((ANU1+COEF1)/COEF2)*Z
      SUM=SUM+TERM
  200 CONTINUE
C
  210 SUM=SUM+1.0D0
      CDF=((1.0D0-Z)**(ANU1/2.0D0))*SUM
      RETURN
C
C     DO THE NU1 ODD AND NU2 ODD CASE
C
  250 SUM=0.0D0
      TERM=1.0D0
      ARG=DSQRT((ANU1/ANU2)*DX)
      THETA=DATAN(ARG)
      SINTH=ARG/DSQRT(1.0D0+ARG*ARG)
      COSTH=1.0D0/DSQRT(1.0D0+ARG*ARG)
      IF(N.EQ.1)GOTO320
      IF(N.EQ.3)GOTO310
      IMAX=N-2
      DO300I=3,IMAX,2
      AI=I
      COEF1=AI-1.0D0
      COEF2=AI
      TERM=TERM*(COEF1/COEF2)*(COSTH*COSTH)
      SUM=SUM+TERM
  300 CONTINUE
C
  310 SUM=SUM+1.0D0
      SUM=SUM*SINTH*COSTH
C
  320 A=(2.0D0/PI)*(THETA+SUM)
  350 SUM=0.0D0
      TERM=1.0D0
      IF(M.EQ.1)B=0.0D0
      IF(M.EQ.1)GOTO450
      IF(M.EQ.3)GOTO410
      IMAX=M-3
      DO400I=1,IMAX,2
      AI=I
      COEF1=AI
      COEF2=AI+2.0D0
      TERM=TERM*((ANU2+COEF1)/COEF2)*(SINTH*SINTH)
      SUM=SUM+TERM
  400 CONTINUE
C
  410 SUM=SUM+1.0D0
      SUM=SUM*SINTH*(COSTH**N)
      COEF=1.0D0
      IEVODD=N-2*(N/2)
      IMIN=3
      IF(IEVODD.EQ.0)IMIN=2
      IF(IMIN.GT.N)GOTO420
      DO430I=IMIN,N,2
      AI=I
      COEF=((AI-1.0D0)/AI)*COEF
  430 CONTINUE
C
  420 COEF=COEF*ANU2
      IF(IEVODD.EQ.0)GOTO440
      COEF=COEF*(2.0D0/PI)
C
  440 B=COEF*SUM
C
  450 CDF=A-B
      RETURN
C
C     TREAT THE CASE WHEN NU1 AND NU2
C     ARE BOTH LARGE
C     (THAT IS, BOTH ARE EQUAL TO OR LARGER THAN 1000);
C     OR WHEN NU1 IS MODERATE AND NU2 IS LARGE
C     (THAT IS, WHEN NU1 IS EQUAL TO OR GREATER THAN 100
C     BUT SMALLER THAN 1000,
C     AND NU2 IS EQUAL TO OR LARGER THAN 1000);
C     OR WHEN NU2 IS MODERATE AND NU1 IS LARGE
C     (THAT IS WHEN NU2 IS EQUAL TO OR GREATER THAN 100
C     BUT SMALLER THAN 1000,
C     AND NU1 IS EQUAL TO OR LARGER THAN 1000).
C     METHOD UTILIZED--PAULSON APPROXIMATION
C     (SEE AMS 55, PAGE 947, FORMULA 26.6.15).
C
 2000 CONTINUE
      DFACT1=1.0D0/(4.5D0*DNU1)
      DFACT2=1.0D0/(4.5D0*DNU2)
      DPOW1=1.0D0/3.0D0
      DPOW2=2.0D0/3.0D0
      DNUM=((1.0D0-DFACT2)*(DX**DPOW1))-(1.0D0-DFACT1)
      DDEN=DSQRT((DFACT2*(DX**DPOW2))+DFACT1)
      U=DNUM/DDEN
      CALL NORCDF(U,GCDF)
      CDF=GCDF
      RETURN
C
C     TREAT THE CASE WHEN NU1 IS SMALL
C     AND NU2 IS LARGE
C     (THAT IS, WHEN NU1 IS SMALLER THAN 100,
C     AND NU2 IS EQUAL TO OR LARGER THAN 1000).
C     METHOD UTILIZED--SHEFFE-TUKEY APPROXIMATION
C     (SEE JOHNSON AND KOTZ, VOLUME 2, PAGE 84, THIRD FORMULA).
C
 3000 CONTINUE
      TERM1=DNU1
      TERM2=(DNU1/DNU2)*(0.5D0*DNU1-1.0D0)
      TERM3=-(DNU1/DNU2)*0.5D0
      U=(TERM1+TERM2)/((1.0D0/DX)-TERM3)
      CALL CHSCDF(U,NU1,CCDF)
      CDF=CCDF
      RETURN
C
C     TREAT THE CASE WHEN NU2 IS SMALL
C     AND NU1 IS LARGE
C     (THAT IS, WHEN NU2 IS SMALLER THAN 100,
C     AND NU1 IS EQUAL TO OR LARGER THAN 1000).
C     METHOD UTILIZED--SHEFFE-TUKEY APPROXIMATION
C     (SEE JOHNSON AND KOTZ, VOLUME 2, PAGE 84, THIRD FORMULA).
C
 5000 CONTINUE
      TERM1=DNU2
      TERM2=(DNU2/DNU1)*(0.5D0*DNU2-1.0D0)
      TERM3=-(DNU2/DNU1)*0.5D0
      U=(TERM1+TERM2)/(DX-TERM3)
      CALL CHSCDF(U,NU2,CCDF)
      CDF=1.0-CCDF
      RETURN
C
      END
      DOUBLE PRECISION FUNCTION FDM0P5(XVALUE)
C
C   DESCRIPTION:
C
C      This function computes the Fermi-Dirac function of
C      order -1/2, defined as
C
C                     Int{0 to inf} t**(-1/2) / (1+exp(t-x)) dt
C         FDM0P5(x) = -----------------------------------------
C                                 Gamma(1/2)
C
C      The function uses Chebyshev expansions which are given to
C      16 decimal places for x <= 2, but only 10 decimal places 
C      for x > 2.
C
C
C   ERROR RETURNS:
C    
C      None.
C
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERMS1 - INTEGER - The number of terms used from the array
C                          ARRFD1. The recommended value is such that
C                               ABS(ARRFD1(NTERMS1)) < EPS/10
C                          subject to 1 <= NTERMS1 <= 14.
C
C      NTERMS2 - INTEGER - The number of terms used from the array
C                          ARRFD2. The recommended value is such that
C                               ABS(ARRFD2(NTERMS2)) < EPS/10
C                          subject to 1 <= NTERMS1 <= 23.
C
C      NTERMS3 - INTEGER - The number of terms used from the array
C                          ARRFD3. The recommended value is such that
C                               ABS(ARRFD3(NTERMS3)) < EPS/10
C                          subject to 1 <= NTERMS3 <= 28.
C
C      XMIN1 - REAL - The value of x below which
C                         FDM0P5(x) = exp(x)
C                     to machine precision. The recommended value
C                     is    LN ( SQRT(2) * EPSNEG )
C
C      XMIN2 - REAL - The value of x below which
C                         FDM0P5(x) = 0.0 
C                     to machine precision. The recommended value
C                     is    LN ( XMIN )
C
C      XHIGH - REAL - The value of x above which
C                         FDM0P5(x) = 2 sqrt (x/pi) 
C                     to machine precision. The recommended value
C                     is    1 / sqrt( 2 * EPSNEG )
C
C      For values of EPS, EPSNEG, and XMIN the user should refer to the
C      paper by Cody in ACM. Trans. Math. Soft. Vol. 14 (1988) p303-311.
C   
C      This code is provided with single and double precision values
C      of the machine-dependent parameters, suitable for machines
C      which satisfy the IEEE floating-point standard.
C
C
C   AUTHOR:
C          DR. ALLAN MACLEOD,
C          DEPT. OF MATHEMATICS AND STATISTICS,
C          UNIVERSITY OF PAISLEY,
C          HIGH ST.,
C          PAISLEY,
C          SCOTLAND
C          PA1 2BE
C
C          (e-mail: macl-ms0@paisley.ac.uk )
C
C
C   LATEST UPDATE:
C                 20 NOVEMBER, 1996
C
      INTEGER NTERM1,NTERM2,NTERM3
      DOUBLE PRECISION
     1     ARRFD1(0:14),ARRFD2(0:23),ARRFD3(0:58),
     2     CHEVAL,CHV,EXPX,FIFTY,FORTY2,
     3     GAM1P5,ONE,T,THREE,TWO,TWOE,
     4     X,XHIGH,XMIN1,XMIN2,XSQ,XVALUE,ZERO
      DATA ARRFD1/1.7863 5963 8510 2264  D   0,
     1           -0.9993 7200 7632 333   D  -1,
     2            0.6414 4652 2160 54    D  -2,
     3           -0.4356 4153 7134 5     D  -3,
     4            0.3052 1670 0310       D  -4,
     5           -0.2181 0648 110        D  -5,
     6            0.1580 0507 81         D  -6,
     7           -0.1156 2057 0          D  -7,
     8            0.8525 860             D  -9,
     9           -0.6325 29              D -10,
     X            0.4715 9               D -11,
     1           -0.3530                 D -12,
     2            0.265                  D -13,
     3           -0.20                   D -14,
     4            0.2                    D -15/
      DATA ARRFD2( 0)/ 1.6877 1115 2605 2352  D   0/
      DATA ARRFD2( 1)/ 0.5978 3602 2633 6983  D   0/
      DATA ARRFD2( 2)/ 0.3572 2600 4541 669   D  -1/
      DATA ARRFD2( 3)/-0.1321 4478 6506 426   D  -1/
      DATA ARRFD2( 4)/-0.4040 1342 0744 7     D  -3/
      DATA ARRFD2( 5)/ 0.5330 0118 4688 7     D  -3/
      DATA ARRFD2( 6)/-0.1489 2350 4863       D  -4/
      DATA ARRFD2( 7)/-0.2188 6382 2916       D  -4/
      DATA ARRFD2( 8)/ 0.1965 2084 277        D  -5/
      DATA ARRFD2( 9)/ 0.8565 8304 66         D  -6/
      DATA ARRFD2(10)/-0.1407 7231 33         D  -6/
      DATA ARRFD2(11)/-0.3051 7580 3          D  -7/
      DATA ARRFD2(12)/ 0.8352 4532            D  -8/
      DATA ARRFD2(13)/ 0.9025 750             D  -9/
      DATA ARRFD2(14)/-0.4455 471             D  -9/
      DATA ARRFD2(15)/-0.1483 42              D -10/
      DATA ARRFD2(16)/ 0.2192 66              D -10/
      DATA ARRFD2(17)/-0.6579                 D -12/
      DATA ARRFD2(18)/-0.1000 9               D -11/
      DATA ARRFD2(19)/ 0.936                  D -13/
      DATA ARRFD2(20)/ 0.420                  D -13/
      DATA ARRFD2(21)/-0.71                   D -14/
      DATA ARRFD2(22)/-0.16                   D -14/
      DATA ARRFD2(23)/ 0.4                    D -15/
      DATA ARRFD3(0)/  0.8707 1950 2959 0563  D    0/
      DATA ARRFD3(1)/  0.5983 3110 2317 33    D   -2/
      DATA ARRFD3(2)/ -0.4326 7047 0895 746   D   -1/
      DATA ARRFD3(3)/ -0.3930 8368 1608 590   D   -1/
      DATA ARRFD3(4)/ -0.1914 8268 8045 932   D   -1/
      DATA ARRFD3(5)/ -0.6558 2880 9801 58    D   -2/
      DATA ARRFD3(6)/ -0.2227 6691 5163 12    D   -2/
      DATA ARRFD3(7)/ -0.8466 7869 3617 8     D   -3/
      DATA ARRFD3(8)/ -0.2807 4594 8921 9     D   -3/
      DATA ARRFD3(9)/ -0.9555 7502 4348       D   -4/
      DATA ARRFD3(10)/-0.3623 6766 2803       D   -4/
      DATA ARRFD3(11)/-0.1091 5846 8869       D   -4/
      DATA ARRFD3(12)/-0.3935 6701 000        D   -5/
      DATA ARRFD3(13)/-0.1310 8192 725        D   -5/
      DATA ARRFD3(14)/-0.2468 8163 88         D   -6/
      DATA ARRFD3(15)/-0.1048 3803 11         D   -6/
      DATA ARRFD3(16)/ 0.2361 8148 7          D   -7/
      DATA ARRFD3(17)/ 0.2271 4535 9          D   -7/
      DATA ARRFD3(18)/ 0.1457 7517 4          D   -7/
      DATA ARRFD3(19)/ 0.1539 2676 7          D   -7/
      DATA ARRFD3(20)/ 0.5692 4772            D   -8/
      DATA ARRFD3(21)/ 0.5062 3068            D   -8/
      DATA ARRFD3(22)/ 0.2342 6075            D   -8/
      DATA ARRFD3(23)/ 0.1265 2275            D   -8/
      DATA ARRFD3(24)/ 0.8927 773             D   -9/
      DATA ARRFD3(25)/ 0.2994 501             D   -9/
      DATA ARRFD3(26)/ 0.2822 785             D   -9/
      DATA ARRFD3(27)/ 0.9106 85              D  -10/
      DATA ARRFD3(28)/ 0.6962 85              D  -10/
      DATA ARRFD3(29)/ 0.3662 25              D  -10/
      DATA ARRFD3(30)/ 0.1243 51              D  -10/
      DATA ARRFD3(31)/ 0.1450 19              D  -10/
      DATA ARRFD3(32)/ 0.1664 5               D  -11/
      DATA ARRFD3(33)/ 0.4585 6               D  -11/
      DATA ARRFD3(34)/ 0.6092                 D  -12/
      DATA ARRFD3(35)/ 0.9331                 D  -12/
      DATA ARRFD3(36)/ 0.5238                 D  -12/
      DATA ARRFD3(37)/-0.56                   D  -14/
      DATA ARRFD3(38)/ 0.3170                 D  -12/
      DATA ARRFD3(39)/-0.926                  D  -13/
      DATA ARRFD3(40)/ 0.1265                 D  -12/
      DATA ARRFD3(41)/-0.327                  D  -13/
      DATA ARRFD3(42)/ 0.276                  D  -13/
      DATA ARRFD3(43)/ 0.33                   D  -14/
      DATA ARRFD3(44)/-0.42                   D  -14/
      DATA ARRFD3(45)/ 0.101                  D  -13/
      DATA ARRFD3(46)/-0.73                   D  -14/
      DATA ARRFD3(47)/ 0.64                   D  -14/
      DATA ARRFD3(48)/-0.37                   D  -14/
      DATA ARRFD3(49)/ 0.23                   D  -14/
      DATA ARRFD3(50)/-0.9                    D  -15/
      DATA ARRFD3(51)/ 0.2                    D  -15/
      DATA ARRFD3(52)/ 0.2                    D  -15/
      DATA ARRFD3(53)/-0.3                    D  -15/
      DATA ARRFD3(54)/ 0.4                    D  -15/
      DATA ARRFD3(55)/-0.3                    D  -15/
      DATA ARRFD3(56)/ 0.2                    D  -15/
      DATA ARRFD3(57)/-0.1                    D  -15/
      DATA ARRFD3(58)/ 0.1                    D  -15/
      DATA ZERO,ONE,TWO/ 0.0 D 0 , 1.0 D 0 , 2.0 D 0/
      DATA THREE,FORTY2,FIFTY/ 3.0 D 0 , 42.0 D 0 , 50.0 D 0/
      DATA GAM1P5/0.8862 2692 5452 7580 D 0/
      DATA TWOE/5.4365 6365 6918 0905 D 0/
C
C   Machine-dependent constants
C
      DATA NTERM1,NTERM2,NTERM3/14,23,58/
      DATA XMIN1,XMIN2,XHIGH/-36.39023D0,-708.39641D0,67108864.0D0/
C
C   Start calculation
C
      X=XVALUE
C
C   Code for x < -1
C
      IF ( X .LT. -ONE ) THEN
         IF ( X .GT. XMIN1 ) THEN
            EXPX = EXP(X)
            T = TWOE * EXPX - ONE
            FDM0P5 = EXPX * CHEVAL ( NTERM1 , ARRFD1 , T )
         ELSE
            IF ( X .LT. XMIN2 ) THEN
               FDM0P5 = ZERO
            ELSE
               FDM0P5 = EXP(X)
            ENDIF
         ENDIF
      ELSE
C
C   Code for -1 <= x <= 2
C
         IF ( X .LE. TWO ) THEN
            T = ( TWO * X - ONE ) / THREE
            FDM0P5 = CHEVAL ( NTERM2 , ARRFD2 , T )
         ELSE
C
C   Code for x > 2
C
            FDM0P5 = SQRT(X) / GAM1P5
            IF ( X .LE. XHIGH ) THEN 
               XSQ = X * X
               T = ( FIFTY - XSQ ) / ( FORTY2 + XSQ )
               CHV = CHEVAL ( NTERM3 , ARRFD3 , T )
               FDM0P5 = FDM0P5 * ( ONE - CHV / XSQ )
            ENDIF
         ENDIF
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION FDP0P5(XVALUE)
C
C   DESCRIPTION:
C
C      This function computes the Fermi-Dirac function of
C      order 1/2, defined as
C
C                     Int{0 to inf} t**(1/2) / (1+exp(t-x)) dt
C         FDP0P5(x) = -----------------------------------------
C                                 Gamma(3/2)
C
C      The function uses Chebyshev expansions which are given to
C      16 decimal places for x <= 2, but only 10 decimal places 
C      for x > 2.
C
C
C   ERROR RETURNS:
C    
C      If XVALUE too large and positive, the function value
C      will overflow. An error message is printed and the function
C      returns the value 0.0.
C
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERMS1 - INTEGER - The number of terms used from the array
C                          ARRFD1. The recommended value is such that
C                               ABS(ARRFD1(NTERMS1)) < EPS/10
C                          subject to 1 <= NTERMS1 <= 13.
C
C      NTERMS2 - INTEGER - The number of terms used from the array
C                          ARRFD2. The recommended value is such that
C                               ABS(ARRFD2(NTERMS2)) < EPS/10
C                          subject to 1 <= NTERMS1 <= 23.
C
C      NTERMS3 - INTEGER - The number of terms used from the array
C                          ARRFD3. The recommended value is such that
C                               ABS(ARRFD3(NTERMS3)) < EPS/10
C                          subject to 1 <= NTERMS3 <= 32.
C
C      XMIN1 - REAL - The value of x below which
C                         FDP0P5(x) = exp(x)
C                     to machine precision. The recommended value
C                     is   1.5*LN(2) + LN(EPSNEG)
C
C      XMIN2 - REAL - The value of x below which
C                         FDP0P5(x) = 0.0 
C                     to machine precision. The recommended value
C                     is    LN ( XMIN )
C
C      XHIGH1 - REAL - The value of x above which
C                         FDP0P5(x) = x**(3/2)/GAMMA(5/2)
C                     to machine precision. The recommended value
C                     is   pi / SQRT(8*EPS)
C
C      XHIGH2 - REAL - The value of x above which FDP0P5 would 
C                      overflow. The reommended value is
C                              (1.329*XMAX)**(2/3)
C
C      For values of EPS, EPSNEG, and XMIN the user should refer to the
C      paper by Cody in ACM. Trans. Math. Soft. Vol. 14 (1988) p303-311.
C   
C      This code is provided with single and double precision values
C      of the machine-dependent parameters, suitable for machines
C      which satisfy the IEEE floating-point standard.
C
C
C   AUTHOR:
C          DR. ALLAN MACLEOD,
C          DEPT. OF MATHEMATICS AND STATISTICS,
C          UNIVERSITY OF PAISLEY,
C          HIGH ST.,
C          PAISLEY,
C          SCOTLAND
C          PA1 2BE
C
C          (e-mail: macl-ms0@paisley.ac.uk )
C
C
C   LATEST UPDATE:
C                 20 NOVEMBER, 1996
C
      INTEGER NTERM1,NTERM2,NTERM3
      DOUBLE PRECISION
     1     ARRFD1(0:13),ARRFD2(0:23),ARRFD3(0:53),
     2     CHEVAL,CHV,EXPX,FIFTY,FORTY2,
     3     GAM2P5,ONE,T,THREE,TWO,TWOE,X,XHIGH1,
     4     XHIGH2,XMIN1,XMIN2,XSQ,XVALUE,ZERO
C
C-----COMMON----------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ARRFD1/1.8862 9683 9273 4597  D   0,
     1           -0.5435 8081 7644 053   D  -1,
     2            0.2364 4975 4397 20    D  -2,
     3           -0.1216 9293 6588 0     D  -3,
     4            0.6869 5130 622        D  -5,
     5           -0.4112 0761 72         D  -6,
     6            0.2563 5162 8          D  -7,
     7           -0.1646 5008            D  -8,
     8            0.1081 948             D  -9,
     9           -0.7239 2               D -11,
     X            0.4915                 D -12,
     1           -0.338                  D -13,
     2            0.23                   D -14,
     3           -0.2                    D -15/
      DATA ARRFD2( 0)/ 2.6982 4927 8817 0612  D   0/
      DATA ARRFD2( 1)/ 1.2389 9141 4113 3012  D   0/
      DATA ARRFD2( 2)/ 0.2291 4393 7981 6278  D   0/
      DATA ARRFD2( 3)/ 0.9031 6534 6872 79    D  -2/
      DATA ARRFD2( 4)/-0.2577 6524 6912 46    D  -2/
      DATA ARRFD2( 5)/-0.5836 8160 5388       D  -4/
      DATA ARRFD2( 6)/ 0.6936 0945 8725       D  -4/
      DATA ARRFD2( 7)/-0.1806 1670 265        D  -5/
      DATA ARRFD2( 8)/-0.2132 1530 005        D  -5/
      DATA ARRFD2( 9)/ 0.1754 9839 51         D  -6/
      DATA ARRFD2(10)/ 0.6653 2547 0          D  -7/
      DATA ARRFD2(11)/-0.1016 7597 7          D  -7/
      DATA ARRFD2(12)/-0.1963 7597            D  -8/
      DATA ARRFD2(13)/ 0.5075 769             D  -9/
      DATA ARRFD2(14)/ 0.4914 69              D -10/
      DATA ARRFD2(15)/-0.2337 37              D -10/
      DATA ARRFD2(16)/-0.6645                 D -12/
      DATA ARRFD2(17)/ 0.1011 5               D -11/
      DATA ARRFD2(18)/-0.313                  D -13/
      DATA ARRFD2(19)/-0.412                  D -13/
      DATA ARRFD2(20)/ 0.38                   D -14/
      DATA ARRFD2(21)/ 0.16                   D -14/
      DATA ARRFD2(22)/-0.3                    D -15/
      DATA ARRFD2(23)/-0.1                    D -15/
      DATA ARRFD3(0)/  2.5484 3841 9800 9122  D    0/
      DATA ARRFD3(1)/  0.5104 3940 8960 652   D   -1/
      DATA ARRFD3(2)/  0.7749 3527 6282 94    D   -2/
      DATA ARRFD3(3)/ -0.7504 1656 5849 53    D   -2/
      DATA ARRFD3(4)/ -0.7754 0826 3202 96    D   -2/
      DATA ARRFD3(5)/ -0.4581 0844 5399 77    D   -2/
      DATA ARRFD3(6)/ -0.2343 1641 5873 63    D   -2/
      DATA ARRFD3(7)/ -0.1178 8049 5135 91    D   -2/
      DATA ARRFD3(8)/ -0.5802 7393 5970 2     D   -3/
      DATA ARRFD3(9)/ -0.2825 3507 0053 7     D   -3/
      DATA ARRFD3(10)/-0.1388 1366 5179 9     D   -3/
      DATA ARRFD3(11)/-0.6806 9508 4875       D   -4/
      DATA ARRFD3(12)/-0.3353 5635 0608       D   -4/
      DATA ARRFD3(13)/-0.1665 3301 8734       D   -4/
      DATA ARRFD3(14)/-0.8271 4908 266        D   -5/
      DATA ARRFD3(15)/-0.4142 5714 409        D   -5/
      DATA ARRFD3(16)/-0.2080 5255 294        D   -5/
      DATA ARRFD3(17)/-0.1047 9767 478        D   -5/
      DATA ARRFD3(18)/-0.5315 2738 02         D   -6/
      DATA ARRFD3(19)/-0.2694 0611 78         D   -6/
      DATA ARRFD3(20)/-0.1374 8787 49         D   -6/
      DATA ARRFD3(21)/-0.7023 0888 7          D   -7/
      DATA ARRFD3(22)/-0.3595 4394 2          D   -7/
      DATA ARRFD3(23)/-0.1851 0612 6          D   -7/
      DATA ARRFD3(24)/-0.9502 3937            D   -8/
      DATA ARRFD3(25)/-0.4918 4811            D   -8/
      DATA ARRFD3(26)/-0.2537 1950            D   -8/
      DATA ARRFD3(27)/-0.1315 1532            D   -8/
      DATA ARRFD3(28)/-0.6835 168             D   -9/
      DATA ARRFD3(29)/-0.3538 244             D   -9/
      DATA ARRFD3(30)/-0.1853 182             D   -9/
      DATA ARRFD3(31)/-0.9589 83              D  -10/
      DATA ARRFD3(32)/-0.5040 83              D  -10/
      DATA ARRFD3(33)/-0.2622 38              D  -10/
      DATA ARRFD3(34)/-0.1372 55              D  -10/
      DATA ARRFD3(35)/-0.7234 0               D  -11/
      DATA ARRFD3(36)/-0.3742 9               D  -11/
      DATA ARRFD3(37)/-0.2005 9               D  -11/
      DATA ARRFD3(38)/-0.1026 9               D  -11/
      DATA ARRFD3(39)/-0.5551                 D  -12/
      DATA ARRFD3(40)/-0.2857                 D  -12/
      DATA ARRFD3(41)/-0.1520                 D  -12/
      DATA ARRFD3(42)/-0.811                  D  -13/
      DATA ARRFD3(43)/-0.410                  D  -13/
      DATA ARRFD3(44)/-0.234                  D  -13/
      DATA ARRFD3(45)/-0.110                  D  -13/
      DATA ARRFD3(46)/-0.67                   D  -14/
      DATA ARRFD3(47)/-0.30                   D  -14/
      DATA ARRFD3(48)/-0.19                   D  -14/
      DATA ARRFD3(49)/-0.9                    D  -15/
      DATA ARRFD3(50)/-0.5                    D  -15/
      DATA ARRFD3(51)/-0.3                    D  -15/
      DATA ARRFD3(52)/-0.1                    D  -15/
      DATA ARRFD3(53)/-0.1                    D  -15/
      DATA ZERO,ONE,TWO/ 0.0 D 0 , 1.0 D 0 , 2.0 D 0/
      DATA THREE,FORTY2,FIFTY/ 3.0 D 0 , 42.0 D 0 , 50.0 D 0/
      DATA GAM2P5/0.1329 3403 8817 9137 D 1/
      DATA TWOE/5.4365 6365 6918 0905 D 0/
C
C   Machine-dependent constants (suitable for IEEE machines)
C
      DATA NTERM1,NTERM2,NTERM3/13,23,53/
      DATA XMIN1,XMIN2/-35.7D00,-708.394D00/
      DATA XHIGH1,XHIGH2/7.45467D7,3.8392996D205/
C
C   Start calculation
C
      X=XVALUE
C
C   Test for error condition
C
      IF ( X .GT. XHIGH2 ) THEN
         WRITE(ICOUT,11)
   11    FORMAT('**** ERROR FROM FDP0P5: X (=',G15.7,') TOO LARGE, ',
     1          'WOULD RESULT IN OVERFLOW.')
         CALL DPWRST('XXX','BUG ')
         FDP0P5 = ZERO
         RETURN
      ENDIF    
C
C   Code for x < -1
C
      IF ( X .LT. -ONE ) THEN
         IF ( X .GT. XMIN1 ) THEN
            EXPX = EXP(X)
            T = TWOE * EXPX - ONE
            FDP0P5 = EXPX * CHEVAL ( NTERM1 , ARRFD1 , T )
         ELSE
            IF ( X .LT. XMIN2 ) THEN
               FDP0P5 = ZERO
            ELSE
               FDP0P5 = EXP(X)
            ENDIF
         ENDIF
      ELSE
C
C   Code for -1 <= x <= 2
C
         IF ( X .LE. TWO ) THEN
            T = ( TWO * X - ONE ) / THREE
            FDP0P5 = CHEVAL ( NTERM2 , ARRFD2 , T )
         ELSE
C
C   Code for x > 2
C
            FDP0P5 = X * SQRT(X) / GAM2P5
            IF ( X .LE. XHIGH1 ) THEN 
               XSQ = X * X
               T = ( FIFTY - XSQ ) / ( FORTY2 + XSQ )
               CHV = CHEVAL ( NTERM3 , ARRFD3 , T )
               FDP0P5 = FDP0P5 * ( ONE + CHV / XSQ )
            ENDIF
         ENDIF
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION FDP1P5(XVALUE)
C
C   DESCRIPTION:
C
C      This function computes the Fermi-Dirac function of
C      order 3/2, defined as
C
C                     Int{0 to inf} t**(3/2) / (1+exp(t-x)) dt
C         FDP1P5(x) = -----------------------------------------
C                                 Gamma(5/2)
C
C      The function uses Chebyshev expansions which are given to
C      16 decimal places for x <= 2, but only 10 decimal places 
C      for x > 2.
C
C
C   ERROR RETURNS:
C    
C      If XVALUE too large and positive, the function value
C      will overflow. An error message is printed and the function
C      returns the value 0.0.
C
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERMS1 - INTEGER - The number of terms used from the array
C                          ARRFD1. The recommended value is such that
C                               ABS(ARRFD1(NTERMS1)) < EPS/10
C                          subject to 1 <= NTERMS1 <= 12.
C
C      NTERMS2 - INTEGER - The number of terms used from the array
C                          ARRFD2. The recommended value is such that
C                               ABS(ARRFD2(NTERMS2)) < EPS/10
C                          subject to 1 <= NTERMS1 <= 22.
C
C      NTERMS3 - INTEGER - The number of terms used from the array
C                          ARRFD3. The recommended value is such that
C                               ABS(ARRFD3(NTERMS3)) < EPS/10
C                          subject to 1 <= NTERMS3 <= 33.
C
C      XMIN1 - REAL - The value of x below which
C                         FDP1P5(x) = exp(x)
C                     to machine precision. The recommended value
C                     is   2.5*LN(2) + LN(EPSNEG)
C
C      XMIN2 - REAL - The value of x below which
C                         FDP1P5(x) = 0.0 
C                     to machine precision. The recommended value
C                     is    LN ( XMIN )
C
C      XHIGH1 - REAL - The value of x above which
C                         FDP1P5(x) = x**(5/2)/GAMMA(7/2) 
C                     to machine precision. The recommended value
C                     is   pi * SQRT(1.6/EPS)
C
C      XHIGH2 - REAL - The value of x above which FDP1P5 would 
C                      overflow. The reommended value is
C                              (3.233509*XMAX)**(2/5)
C
C      For values of EPS, EPSNEG, and XMIN the user should refer to the
C      paper by Cody in ACM. Trans. Math. Soft. Vol. 14 (1988) p303-311.
C   
C      This code is provided with single and double precision values
C      of the machine-dependent parameters, suitable for machines
C      which satisfy the IEEE floating-point standard.
C
C
C   AUTHOR:
C          DR. ALLAN MACLEOD,
C          DEPT. OF MATHEMATICS AND STATISTICS,
C          UNIVERSITY OF PAISLEY,
C          HIGH ST.,
C          PAISLEY,
C          SCOTLAND
C          PA1 2BE
C
C          (e-mail: macl_ms0@paisley.ac.uk )
C
C
C   LATEST UPDATE:
C                 21 NOVEMBER, 1996
C
      INTEGER NTERM1,NTERM2,NTERM3
      DOUBLE PRECISION
     1     ARRFD1(0:12),ARRFD2(0:22),ARRFD3(0:55),
     2     CHEVAL,CHV,EXPX,FIFTY,FORTY2,
     3     GAM3P5,ONE,T,THREE,TWO,TWOE,X,XHIGH1,
     4     XHIGH2,XMIN1,XMIN2,XSQ,XVALUE,ZERO
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ARRFD1/1.9406 5492 1037 8650  D   0,
     1           -0.2878 6747 5518 043   D  -1,
     2            0.8509 1579 5231 3     D  -3,
     3           -0.3327 8452 5669       D  -4,
     4            0.1517 1202 058        D  -5,
     5           -0.7622 0087 4          D  -7,
     6            0.4095 5489            D  -8,
     7           -0.2311 964             D  -9,
     8            0.1355 37              D -10,
     9           -0.8187                 D -12,
     X            0.507                  D -13,
     1           -0.32                   D -14,
     2            0.2                    D -15/
      DATA ARRFD2( 0)/ 3.5862 2516 1563 4306 D   0/
      DATA ARRFD2( 1)/ 1.8518 2900 5626 5751 D   0/
      DATA ARRFD2( 2)/ 0.4612 3491 0241 7150 D   0/
      DATA ARRFD2( 3)/ 0.5793 0397 6126 881  D  -1/
      DATA ARRFD2( 4)/ 0.1704 3790 5548 75   D  -2/
      DATA ARRFD2( 5)/-0.3970 5201 2249 6    D  -3/
      DATA ARRFD2( 6)/-0.7070 2491 890       D  -5/
      DATA ARRFD2( 7)/ 0.7659 9748 792       D  -5/
      DATA ARRFD2( 8)/-0.1857 8113 33        D  -6/
      DATA ARRFD2( 9)/-0.1832 2379 56        D  -6/
      DATA ARRFD2(10)/ 0.1392 4949 5         D  -7/
      DATA ARRFD2(11)/ 0.4670 2027           D  -8/
      DATA ARRFD2(12)/-0.6671 984            D  -9/
      DATA ARRFD2(13)/-0.1161 292            D  -9/
      DATA ARRFD2(14)/ 0.2844 38             D -10/
      DATA ARRFD2(15)/ 0.2490 6              D -11/
      DATA ARRFD2(16)/-0.1143 1              D -11/
      DATA ARRFD2(17)/-0.279                 D -13/
      DATA ARRFD2(18)/ 0.439                 D -13/
      DATA ARRFD2(19)/-0.14                  D -14/
      DATA ARRFD2(20)/-0.16                  D -14/
      DATA ARRFD2(21)/ 0.1                   D -15/
      DATA ARRFD2(22)/ 0.1                   D -15/
      DATA ARRFD3( 0)/12.1307 5817 3688 4627  D   0/
      DATA ARRFD3( 1)/-0.1547 5011 1128 7255  D   0/
      DATA ARRFD3( 2)/-0.7390 0738 8850 999   D  -1/
      DATA ARRFD3( 3)/-0.3072 3537 7959 258   D  -1/
      DATA ARRFD3( 4)/-0.1145 4857 9330 328   D  -1/
      DATA ARRFD3( 5)/-0.4056 7636 8095 39    D  -2/
      DATA ARRFD3( 6)/-0.1398 0158 3732 27    D  -2/
      DATA ARRFD3( 7)/-0.4454 9018 1015 3     D  -3/
      DATA ARRFD3( 8)/-0.1173 9461 1270 4     D  -3/
      DATA ARRFD3( 9)/-0.1484 0898 0093       D  -4/
      DATA ARRFD3(10)/ 0.1188 9515 4223       D  -4/
      DATA ARRFD3(11)/ 0.1464 7695 8178       D  -4/
      DATA ARRFD3(12)/ 0.1132 2874 1730       D  -4/
      DATA ARRFD3(13)/ 0.7576 2292 948        D  -5/
      DATA ARRFD3(14)/ 0.4712 0400 466        D  -5/
      DATA ARRFD3(15)/ 0.2813 2628 202        D  -5/
      DATA ARRFD3(16)/ 0.1637 0517 341        D  -5/
      DATA ARRFD3(17)/ 0.9351 0762 72         D  -6/
      DATA ARRFD3(18)/ 0.5278 6892 10         D  -6/
      DATA ARRFD3(19)/ 0.2951 0798 70         D  -6/
      DATA ARRFD3(20)/ 0.1638 6001 90         D  -6/
      DATA ARRFD3(21)/ 0.9052 0540 9          D  -7/
      DATA ARRFD3(22)/ 0.4977 5697 5          D  -7/
      DATA ARRFD3(23)/ 0.2729 5586 3          D  -7/
      DATA ARRFD3(24)/ 0.1492 1458 5          D  -7/
      DATA ARRFD3(25)/ 0.8142 0359            D  -8/
      DATA ARRFD3(26)/ 0.4434 9200            D  -8/
      DATA ARRFD3(27)/ 0.2411 6032            D  -8/
      DATA ARRFD3(28)/ 0.1310 5018            D  -8/
      DATA ARRFD3(29)/ 0.7109 736             D  -9/
      DATA ARRFD3(30)/ 0.3856 721             D  -9/
      DATA ARRFD3(31)/ 0.2089 529             D  -9/
      DATA ARRFD3(32)/ 0.1131 735             D  -9/
      DATA ARRFD3(33)/ 0.6127 85              D -10/
      DATA ARRFD3(34)/ 0.3314 48              D -10/
      DATA ARRFD3(35)/ 0.1794 19              D -10/
      DATA ARRFD3(36)/ 0.9695 3               D -11/
      DATA ARRFD3(37)/ 0.5246 3               D -11/
      DATA ARRFD3(38)/ 0.2834 3               D -11/
      DATA ARRFD3(39)/ 0.1532 3               D -11/
      DATA ARRFD3(40)/ 0.8284                 D -12/
      DATA ARRFD3(41)/ 0.4472                 D -12/
      DATA ARRFD3(42)/ 0.2421                 D -12/
      DATA ARRFD3(43)/ 0.1304                 D -12/
      DATA ARRFD3(44)/ 0.707                  D -13/
      DATA ARRFD3(45)/ 0.381                  D -13/
      DATA ARRFD3(46)/ 0.206                  D -13/
      DATA ARRFD3(47)/ 0.111                  D -13/
      DATA ARRFD3(48)/ 0.60                   D -14/
      DATA ARRFD3(49)/ 0.33                   D -14/
      DATA ARRFD3(50)/ 0.17                   D -14/
      DATA ARRFD3(51)/ 0.11                   D -14/
      DATA ARRFD3(52)/ 0.5                    D -15/
      DATA ARRFD3(53)/ 0.3                    D -15/
      DATA ARRFD3(54)/ 0.1                    D -15/
      DATA ARRFD3(55)/ 0.1                    D -15/
      DATA ZERO,ONE,TWO/ 0.0 D 0 , 1.0 D 0 , 2.0 D 0/
      DATA THREE,FORTY2,FIFTY/ 3.0 D 0 , 42.0 D 0 , 50.0 D 0/
      DATA GAM3P5/0.3323 3509 7044 7843 D 1/
      DATA TWOE/5.4365 6365 6918 0905 D 0/
C
C   Machine-dependent constants (suitable for IEEE machines)
C
      DATA NTERM1,NTERM2,NTERM3/12,22,55/
      DATA XMIN1,XMIN2/-35.004D0,-708.396418D0/
      DATA XHIGH1,XHIGH2/166674733.2D0,3.204467D123/
C
C   Start calculation
C
      X=XVALUE
C
C   Test for error condition
C
      IF ( X .GT. XHIGH2 ) THEN
         WRITE(ICOUT,11)
   11    FORMAT('**** ERROR FROM FDP1P5: X (=',G15.7,') TOO LARGE, ',
     1          'WOULD RESULT IN OVERFLOW.')
         CALL DPWRST('XXX','BUG ')
         FDP1P5 = ZERO
         RETURN
      ENDIF    
C
C   Code for x < -1
C
      IF ( X .LT. -ONE ) THEN
         IF ( X .GT. XMIN1 ) THEN
            EXPX = EXP(X)
            T = TWOE * EXPX - ONE
            FDP1P5 = EXPX * CHEVAL ( NTERM1 , ARRFD1 , T )
         ELSE
            IF ( X .LT. XMIN2 ) THEN
               FDP1P5 = ZERO
            ELSE
               FDP1P5 = EXP(X)
            ENDIF
         ENDIF
      ELSE
C
C   Code for -1 <= x <= 2
C
         IF ( X .LE. TWO ) THEN
            T = ( TWO * X - ONE ) / THREE
            FDP1P5 = CHEVAL ( NTERM2 , ARRFD2 , T )
         ELSE
C
C   Code for x > 2
C
            FDP1P5 = X * X * SQRT(X) / GAM3P5
            IF ( X .LE. XHIGH1 ) THEN 
               XSQ = X * X
               T = ( FIFTY - XSQ ) / ( FORTY2 + XSQ )
               CHV = CHEVAL ( NTERM3 , ARRFD3 , T )
               FDP1P5 = FDP1P5 * ( ONE + CHV / XSQ )
            ENDIF
         ENDIF
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION FDP2P5(XVALUE)
C
C   DESCRIPTION:
C
C      This function computes the Fermi-Dirac function of
C      order 5/2, defined as
C
C                     Int{0 to inf} t**(5/2) / (1+exp(t-x)) dt
C         FDP2P5(x) = -----------------------------------------
C                                 Gamma(7/2)
C
C      The function uses Chebyshev expansions which are given to
C      16 decimal places for x <= 2, but only 10 decimal places 
C      for x > 2.
C
C
C   ERROR RETURNS:
C    
C      If XVALUE too large and positive, the function value
C      will overflow. An error message is printed and the function
C      returns the value 0.0.
C
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERMS1 - INTEGER - The number of terms used from the array
C                          ARRFD1. The recommended value is such that
C                               ABS(ARRFD1(NTERMS1)) < EPS/10
C                          subject to 1 <= NTERMS1 <= 11.
C
C      NTERMS2 - INTEGER - The number of terms used from the array
C                          ARRFD2. The recommended value is such that
C                               ABS(ARRFD2(NTERMS2)) < EPS/10
C                          subject to 1 <= NTERMS1 <= 21.
C
C      NTERMS3 - INTEGER - The number of terms used from the array
C                          ARRFD3. The recommended value is such that
C                               ABS(ARRFD3(NTERMS3)) < EPS/10
C                          subject to 1 <= NTERMS3 <= 39.
C
C      XMIN1 - REAL - The value of x below which
C                         FDP2P5(x) = exp(x)
C                     to machine precision. The recommended value
C                     is   3.5*LN(2) + LN(EPSNEG)
C
C      XMIN2 - REAL - The value of x below which
C                         FDP2P5(x) = 0.0 
C                     to machine precision. The recommended value
C                     is    LN ( XMIN )
C
C      XHIGH1 - REAL - The value of x above which
C                         FDP2P5(x) = x**(7/2)/GAMMA(9/2) 
C                     to machine precision. The recommended value
C                     is   pi * SQRT(35/(12*EPS))
C
C      XHIGH2 - REAL - The value of x above which FDP2P5 would 
C                      overflow. The reommended value is
C                              (11.6317*XMAX)**(2/7)
C
C      For values of EPS, EPSNEG, and XMIN the user should refer to the
C      paper by Cody in ACM. Trans. Math. Soft. Vol. 14 (1988) p303-311.
C   
C      This code is provided with single and double precision values
C      of the machine-dependent parameters, suitable for machines
C      which satisfy the IEEE floating-point standard.
C
C
C   AUTHOR:
C          DR. ALLAN MACLEOD,
C          DEPT. OF MATHEMATICS AND STATISTICS,
C          UNIVERSITY OF PAISLEY,
C          HIGH ST.,
C          PAISLEY,
C          SCOTLAND
C          PA1 2BE
C
C          (e-mail: macl-ms0@paisley.ac.uk )
C
C
C   LATEST UPDATE:
C                 21 NOVEMBER, 1996
C
      INTEGER NTERM1,NTERM2,NTERM3
      DOUBLE PRECISION
     1     ARRFD1(0:11),ARRFD2(0:21),ARRFD3(0:61),
     2     CHEVAL,CHV,EXPX,FIFTY,FORTY2,
     3     GAM4P5,ONE,T,THREE,TWO,TWOE,X,XHIGH1,
     4     XHIGH2,XMIN1,XMIN2,XSQ,XVALUE,ZERO
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ARRFD1/1.9694 4166 8589 6693  D   0,
     1           -0.1496 9179 4643 492   D  -1,
     2            0.3006 9558 1662 7     D  -3,
     3           -0.8946 2485 950        D  -5,
     4            0.3298 0720 25         D  -6,
     5           -0.1392 3929 8          D  -7,
     6            0.6455 885             D  -9,
     7           -0.3206 23              D -10,
     8            0.1678 3               D -11,
     9           -0.916                  D -13,
     X            0.52                   D -14,
     1           -0.3                    D -15/
      DATA ARRFD2( 0)/ 4.2642 8383 9865 5301  D   0/
      DATA ARRFD2( 1)/ 2.3437 4268 8491 2867  D   0/
      DATA ARRFD2( 2)/ 0.6727 1197 8005 2076  D   0/
      DATA ARRFD2( 3)/ 0.1148 8263 2796 5569  D   0/
      DATA ARRFD2( 4)/ 0.1093 6396 8046 758   D  -1/
      DATA ARRFD2( 5)/ 0.2567 1739 5701 5     D  -3/
      DATA ARRFD2( 6)/-0.5058 8998 3911       D  -4/
      DATA ARRFD2( 7)/-0.7376 2157 74         D  -6/
      DATA ARRFD2( 8)/ 0.7352 9987 58         D  -6/
      DATA ARRFD2( 9)/-0.1664 2173 6          D  -7/
      DATA ARRFD2(10)/-0.1409 2049 9          D  -7/
      DATA ARRFD2(11)/ 0.9949 192             D  -9/
      DATA ARRFD2(12)/ 0.2991 457             D  -9/
      DATA ARRFD2(13)/-0.4013 32              D -10/
      DATA ARRFD2(14)/-0.6354 6               D -11/
      DATA ARRFD2(15)/ 0.1479 3               D -11/
      DATA ARRFD2(16)/ 0.1181                 D -12/
      DATA ARRFD2(17)/-0.524                  D -13/
      DATA ARRFD2(18)/-0.11                   D -14/
      DATA ARRFD2(19)/ 0.18                   D -14/
      DATA ARRFD2(20)/-0.1                    D -15/
      DATA ARRFD2(21)/-0.1                    D -15/
      DATA ARRFD3( 0)/30.2895 6768 5980 2579  D   0/
      DATA ARRFD3( 1)/ 1.1678 9766 4206 0562  D   0/
      DATA ARRFD3( 2)/ 0.6420 5918 0082 1472  D   0/
      DATA ARRFD3( 3)/ 0.3461 7238 6840 7417  D   0/
      DATA ARRFD3( 4)/ 0.1840 8167 9078 1889  D   0/
      DATA ARRFD3( 5)/ 0.9730 9243 5354 509   D  -1/
      DATA ARRFD3( 6)/ 0.5139 7329 2675 393   D  -1/
      DATA ARRFD3( 7)/ 0.2717 0980 1041 757   D  -1/
      DATA ARRFD3( 8)/ 0.1438 3327 1401 165   D  -1/
      DATA ARRFD3( 9)/ 0.7626 4863 9521 55    D  -2/
      DATA ARRFD3(10)/ 0.4050 3695 7672 02    D  -2/
      DATA ARRFD3(11)/ 0.2154 3961 4641 49    D  -2/
      DATA ARRFD3(12)/ 0.1147 5689 9017 77    D  -2/
      DATA ARRFD3(13)/ 0.6120 6223 6928 2     D  -3/
      DATA ARRFD3(14)/ 0.3268 3403 3785 9     D  -3/
      DATA ARRFD3(15)/ 0.1747 1455 2274 2     D  -3/
      DATA ARRFD3(16)/ 0.9348 7845 7860       D  -4/
      DATA ARRFD3(17)/ 0.5006 9221 2553       D  -4/
      DATA ARRFD3(18)/ 0.2683 7382 1846       D  -4/
      DATA ARRFD3(19)/ 0.1439 5719 1251       D  -4/
      DATA ARRFD3(20)/ 0.7727 2440 700        D  -5/
      DATA ARRFD3(21)/ 0.4150 3820 336        D  -5/
      DATA ARRFD3(22)/ 0.2230 5118 261        D  -5/
      DATA ARRFD3(23)/ 0.1199 3697 093        D  -5/
      DATA ARRFD3(24)/ 0.6452 3443 69         D  -6/
      DATA ARRFD3(25)/ 0.3472 8228 81         D  -6/
      DATA ARRFD3(26)/ 0.1869 9642 15         D  -6/
      DATA ARRFD3(27)/ 0.1007 3002 72         D  -6/
      DATA ARRFD3(28)/ 0.5428 0756 1          D  -7/
      DATA ARRFD3(29)/ 0.2926 0782 9          D  -7/
      DATA ARRFD3(30)/ 0.1577 8591 8          D  -7/
      DATA ARRFD3(31)/ 0.8511 0768            D  -8/
      DATA ARRFD3(32)/ 0.4592 2760            D  -8/
      DATA ARRFD3(33)/ 0.2478 5001            D  -8/
      DATA ARRFD3(34)/ 0.1338 0255            D  -8/
      DATA ARRFD3(35)/ 0.7225 103             D  -9/
      DATA ARRFD3(36)/ 0.3902 350             D  -9/
      DATA ARRFD3(37)/ 0.2108 157             D  -9/
      DATA ARRFD3(38)/ 0.1139 122             D  -9/
      DATA ARRFD3(39)/ 0.6156 38              D -10/
      DATA ARRFD3(40)/ 0.3327 81              D -10/
      DATA ARRFD3(41)/ 0.1799 19              D -10/
      DATA ARRFD3(42)/ 0.9728 8               D -11/
      DATA ARRFD3(43)/ 0.5261 7               D -11/
      DATA ARRFD3(44)/ 0.2846 1               D -11/
      DATA ARRFD3(45)/ 0.1539 7               D -11/
      DATA ARRFD3(46)/ 0.8331                 D -12/
      DATA ARRFD3(47)/ 0.4508                 D -12/
      DATA ARRFD3(48)/ 0.2440                 D -12/
      DATA ARRFD3(49)/ 0.1321                 D -12/
      DATA ARRFD3(50)/ 0.715                  D -13/
      DATA ARRFD3(51)/ 0.387                  D -13/
      DATA ARRFD3(52)/ 0.210                  D -13/
      DATA ARRFD3(53)/ 0.114                  D -13/
      DATA ARRFD3(54)/ 0.61                   D -14/
      DATA ARRFD3(55)/ 0.33                   D -14/
      DATA ARRFD3(56)/ 0.18                   D -14/
      DATA ARRFD3(57)/ 0.11                   D -14/
      DATA ARRFD3(58)/ 0.5                    D -15/
      DATA ARRFD3(59)/ 0.3                    D -15/
      DATA ARRFD3(60)/ 0.2                    D -15/
      DATA ARRFD3(61)/ 0.1                    D -15/
      DATA ZERO,ONE,TWO/ 0.0 D 0 , 1.0 D 0 , 2.0 D 0/
      DATA THREE,FORTY2,FIFTY/ 3.0 D 0 , 42.0 D 0 , 50.0 D 0/
      DATA GAM4P5/0.1163 1728 3965 6745 D 2/
      DATA TWOE/5.4365 6365 6918 0905 D 0/
C
C   Machine-dependent constants (suitable for IEEE machines)
C
      DATA NTERM1,NTERM2,NTERM3/11,21,61/
      DATA XMIN1,XMIN2/-34.3107854D0,-708.396418D0/
      DATA XHIGH1,XHIGH2/254599860.5D0,2.383665D88/
C
C   Start calculation
C
      X=XVALUE
C
C   Test for error condition
C
      IF ( X .GT. XHIGH2 ) THEN
         WRITE(ICOUT,11)
   11    FORMAT('**** ERROR FROM FDP2P5: X (=',G15.7,') TOO LARGE, ',
     1          'WOULD RESULT IN OVERFLOW.')
         CALL DPWRST('XXX','BUG ')
         FDP2P5 = ZERO
         RETURN
      ENDIF    
C
C   Code for x < -1
C
      IF ( X .LT. -ONE ) THEN
         IF ( X .GT. XMIN1 ) THEN
            EXPX = EXP(X)
            T = TWOE * EXPX - ONE
            FDP2P5 = EXPX * CHEVAL ( NTERM1 , ARRFD1 , T )
         ELSE
            IF ( X .LT. XMIN2 ) THEN
               FDP2P5 = ZERO
            ELSE
               FDP2P5 = EXP(X)
            ENDIF
         ENDIF
      ELSE
C
C   Code for -1 <= x <= 2
C
         IF ( X .LE. TWO ) THEN
            T = ( TWO * X - ONE ) / THREE
            FDP2P5 = CHEVAL ( NTERM2 , ARRFD2 , T )
         ELSE
C
C   Code for x > 2
C
            FDP2P5 = X * X * X * SQRT(X) / GAM4P5
            IF ( X .LE. XHIGH1 ) THEN 
               XSQ = X * X
               T = ( FIFTY - XSQ ) / ( FORTY2 + XSQ )
               CHV = CHEVAL ( NTERM3 , ARRFD3 , T )
               FDP2P5 = FDP2P5 * ( ONE + CHV / XSQ )
            ENDIF
         ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE FIBONN(N,X,IERROR)
C
C     PURPOSE--THIS SUBROUTINE GENERATES THE FIRST N FIBONNACI NUMBERS--
C              1, 1, 2, 3, 5, 8, 13, 21, ...
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF FIBONNACI NUMBERS
C                                TO BE GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                FIBONNACI NUMBERS
C                                WILL BE PLACED.
C     OUTPUT--THE FIRST N FIBONNACI NUMBERS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87.10
C     ORIGINAL VERSION--SEPTEMBER 1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      CPUMA3=CPUMAX/3.0
C
C               ******************************************
C               **  TREAT THE FIBONNACCI SEQUENCE CASE  **
C               ******************************************
C
C               *******************************************
C               **  STEP 1--                             **
C               **  TEST THE INPUT ARGUMENTS FOR ERRORS  **
C               *******************************************
C
      IF(N.GE.1)GOTO190
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,101)
  101 FORMAT('***** ERROR IN GENMS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,102)
  102 FORMAT('      THE LENGTH OF THE DESIRED SEQUENCE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,103)
  103 FORMAT('      OF FIBONNACI NUMBERS MUST BE 1 OR LARGER;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,104)
  104 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,105)N
  105 FORMAT('      N = ',I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  190 CONTINUE
C
C               ******************************
C               **  STEP 2--                **
C               **  GENERATE THE SEQUENCE   **
C               ******************************
C
      X(1)=1.0
      X(2)=1.0
      IF(N.LT.3)GOTO1190
      DO1100I=3,N
      I2=I
      IM2=I-2
      IM1=I-1
      X(I)=X(IM2)+X(IM1)
      IF(X(I).GE.CPUMA3)GOTO1150
 1100 CONTINUE
      GOTO1190
C
 1150 CONTINUE
      I2P1=I2+1
      WRITE(ICOUT,1151)
 1151 FORMAT('***** ERROR IN FIBONN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1152)
 1152 FORMAT('      A NUMBER IN THE FIBONNACCI SEQUENCE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1153)
 1153 FORMAT('      HAS JUST EXCEEDED THE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1154)
 1154 FORMAT('      LARGEST FLOATING POINT NUMBER')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1155)
 1155 FORMAT('      ALLOWABLE FOR THIS COMPUTER (',E15.7,').')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1156)
 1156 FORMAT('      THE VALUE CAUSING THE OVERFLOW WAS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1157)I2P1
 1157 FORMAT('      THE ',I8,'-TH NUMBER IN THE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1158)
 1158 FORMAT('      FIBONNACCI SEQUENCE.')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 1190 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE FILLHT(IPHORI,ICHORI,AUPPER,ALOWER,XHORIZ,NHORP,ICASEF,
     1IBUGU2,ISUBRO,IERROR)
C
C     PURPOSE--FILL IN (LINEARLY INTERPOLATE) VALUES IN THE HORIZON
C              TABLES FROM ELEMENTS IPREV TO ICUR, INCLUSIVE.
C     REFERENCE--ROGERS, DAVID F. (1985).  PROCEDURAL
C                ELEMENTS FOR COMPUTER GRAPHICS.
C                MCGRAW-HILL, NEW YORK, PAGE 197-201.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--88/9
C     ORIGINAL VERSION--AUGUST    1988.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASEF
C
      CHARACTER*4 IBUGU2
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
CCCCC CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION AUPPER(*)
      DIMENSION ALOWER(*)
      DIMENSION XHORIZ(*)
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='FILL'
      ISUBN2='HT  '
C
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'LLHT')GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF FILLHT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGU2,ISUBRO,IERROR
   52 FORMAT('IBUGU2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)ICASEF
   53 FORMAT('ICASEF = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)IPHORI,ICHORI,NHORP
   61 FORMAT('IPHORI,ICHORI,NHORP = ',3I8)
      CALL DPWRST('XXX','BUG ')
      DO65I=IPHORI,ICHORI
      WRITE(ICOUT,66)I,AUPPER(I),ALOWER(I),XHORIZ(I)
   66 FORMAT('I,AUPPER(I),ALOWER(I),XHORIZ(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
   90 CONTINUE
C
      YPU=AUPPER(IPHORI)
      YPL=ALOWER(IPHORI)
      XP=XHORIZ(IPHORI)
C
      YCU=AUPPER(ICHORI)
      YCL=ALOWER(ICHORI)
      XC=XHORIZ(ICHORI)
C
C               **************************************************
C               **  STEP 10--                                   **
C               **  BRANCH, BASED ON                            **
C               **  INDEX DIFFERENCE AND SLOPE                  **
C               **************************************************
C
      IDEL=ICHORI-IPHORI
      IF(IDEL.LE.1)GOTO9000
      IF(XC.EQ.XP)GOTO6000
      GOTO7000
C
C               **************************************************
C               **  STEP 60--                                   **
C     ----------**  TREAT THE CASE OF NON-ADJ. HORIZON CELL     **----------
C               **  AND INFINITE SLOPE                          **
C               **  (SHOULD BE IMPOSSIBLE)                      **
C               **************************************************
C
 6000 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6010)
 6010 FORMAT('***** INTERNAL ERROR IN FILLHT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6011)
 6011 FORMAT('      AT BRANCH POINT 4000 (AN IMPOSSIBLE BRANCH)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6012)
 6012 FORMAT('      CONDITION = ADJACENT CELL BUT INFINITE SLOPE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6013)
 6013 FORMAT('      IF HAVE INFINITE SLOPE, THEN NECESSARILY MUST')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6014)
 6014 FORMAT('      BE IN SAME CELL.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6015)IPHORI,ICHORI
 6015 FORMAT('IPHORI,ICHORI = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6016)XHORIZ(IPHORI),XHORIZ(ICHORI)
 6016 FORMAT('XHORIZ(IPHORI),XHORIZ(ICHORI) = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
C               **************************************************
C               **  STEP 70--                                   **
C     ----------**  TREAT THE CASE OF NON-ADJ. HORIZON CELL     **----------
C               **  AND FINITE SLOPE                            **
C               **************************************************
C
 7000 CONTINUE
      IF(ICASEF.EQ.'UPPE'.OR.ICASEF.EQ.'BOTH')GOTO7100
      GOTO7190
 7100 CONTINUE
      SLOPEU=(YCU-YPU)/(XC-XP)
      IMIN=IPHORI+1
      IMAX=ICHORI-1
      DO7110I=IMIN,IMAX
      XTEMP=XHORIZ(I)
      YTEMPU=YPU+(XTEMP-XP)*SLOPEU
      IF(YTEMPU.GT.AUPPER(I))AUPPER(I)=YTEMPU
 7110 CONTINUE
 7190 CONTINUE
C
      IF(ICASEF.EQ.'LOWE'.OR.ICASEF.EQ.'BOTH')GOTO7200
      GOTO7290
 7200 CONTINUE
      SLOPEL=(YCL-YPL)/(XC-XP)
      IMIN=IPHORI+1
      IMAX=ICHORI-1
      DO7210I=IMIN,IMAX
      XTEMP=XHORIZ(I)
      YTEMPL=YPL+(XTEMP-XP)*SLOPEL
      IF(YTEMPL.LT.ALOWER(I))ALOWER(I)=YTEMPL
 7210 CONTINUE
 7290 CONTINUE
C
C               **************************************************
C               **  STEP 90--                                   **
C               **  EXIT.                                       **
C               **************************************************
C
 9000 CONTINUE
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'LLHT')GOTO9010
      GOTO9090
 9010 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF FILLHT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGU2,ISUBRO,IERROR
 9012 FORMAT('IBUGU2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)ICASEF
 9013 FORMAT('ICASEF = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)IPHORI,ICHORI,NHORP
 9021 FORMAT('IPHORI,ICHORI,NHORP = ',3I8)
      CALL DPWRST('XXX','BUG ')
      DO9025I=IPHORI,ICHORI
      WRITE(ICOUT,9026)I,AUPPER(I),ALOWER(I),XHORIZ(I)
 9026 FORMAT('I,AUPPER(I),ALOWER(I),XHORIZ(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9025 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE FLCDF(X,GAMMA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE FATIGUE LIFE DISTRIBUTION
C              WITH SHAPE PARAMETER = GAMMA
C              AND LOCATION PARAMETER = 1.
C              THE FATIGUE LIFE DISTRIBUTION IS "HALF WAY BETWEEN"
C              THE INVERSE GAUSSIAN DISTRIBUTION AND
C              THE RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION.
C     NOTE--THE FATIGUE LIFE DISTRIBUTION HAS--
C              FLPDF(X,GAMMA) = (IGPDF(X,GAMMA)+RIGPDF(X,GAMMA)) / 2
C                             = ((1+X)/2)*IGPDF(X,GAMMA)
C              FLCDF(X,GAMMA) = (IGCDF(X,GAMMA)+RIGCDF(X,GAMMA)) / 2
C                             = NORCDF((1/GAMMA)*(SQRT(X)-SQRT(1/X)))
C              FLPPF(P,GAMMA) = (SEE FLPPF.FOR)
C     NOTE--THE FATIGUE LIFE DISTRIBUTION--
C              GOES FROM 0 TO INFINITY
C              HAS MEAN = MU = 1
C              HAS STANDARD DEVIATION = MU*GAMMA*SQRT(1+(5/4)*GAMMA**2)
C              HAS SHAPE PARAMETER = GAMMA
C              IS NEAR-SYMMETRIC AND MODERATE-TAILED FOR SMALL GAMMA
C              IS HIGHLY-SKEWED AND LONG-TAILED FOR LARGE GAMMA
C              APPROACHES NORMALITY AS GAMMA APPROACHES 0
C     NOTE--TO OBTAIN THE PPF FOR GENERAL MU,
C           COMPUTE THE PPF FOR X AROUND 1, AND THEN
C           SIMPLY SCALE UP THE HORIZONTAL AXIS X BY THE DESIRED MU
C           AS IN Y2 = MU*Y
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C                                (ALSO = COEF. OF VARIATION)
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE FATIGUE LIFE DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = GAMMA
C             AND WITH SCALE PARAMETER = 1
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--SAM SAUNDERS TALK, MAY 1990
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --JUNE      1999. REVERT TO NORCDF VERSION.
C                                       OTHER CODE PRODUCED NONSENSE.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DTERM1
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.LE.0)GOTO50
      IF(X.LT.0.0)GOTO55
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,51)
   51 FORMAT('***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ',
     1'ARGUMENT TO THE FLCDF SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)GAMMA
   52 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',
     1E15.8,' *****')
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      GOTO9000
   55 CONTINUE
      WRITE(ICOUT,56)
   56 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ',
     1'ARGUMENT TO THE FLCDF SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,57)X
   57 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',
     1E15.8,' *****')
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      GOTO9000
   90 CONTINUE
C
      IF(X.EQ.0.0)GOTO1100
      GOTO1200
C
 1100 CONTINUE
      CDF=0.0
      GOTO9000
C
 1200 CONTINUE
CCCCC CALL IGCDF(X,GAMMA,CDF1)
CCCCC CALL RIGCDF(X,GAMMA,CDF2)
CCCCC CDF=(CDF1+CDF2)/2.0
      DX=DBLE(X)
      DGAMMA=DBLE(GAMMA)
      DTERM1=(DSQRT(DX)-DSQRT(1.0D0/DX))/DGAMMA 
      CALL NODCDF(DTERM1,DCDF)
      CDF=REAL(DCDF)
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE FLCHA(X,GAMMA,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE FATIGUE LIFE DISTRIBUTION
C              WITH SHAPE PARAMETER = GAMMA
C              AND LOCATION PARAMETER = 1.
C              THE FATIGUE LIFE DISTRIBUTION IS "HALF WAY BETWEEN"
C              THE INVERSE GAUSSIAN DISTRIBUTION AND
C              THE RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION.
C     NOTE--THE FATIGUE LIFE DISTRIBUTION HAS--
C              FLPDF(X,GAMMA) = (IGPDF(X,GAMMA)+RIGPDF(X,GAMMA)) / 2
C                             = ((1+X)/2)*IGPDF(X,GAMMA)
C              FLCDF(X,GAMMA) = (IGCDF(X,GAMMA)+RIGCDF(X,GAMMA)) / 2
C                             = NORCDF((1/GAMMA)*(SQRT(X)-SQRT(1/X)))
C              FLPPF(P,GAMMA) = (SEE FLPPF.FOR)
C     NOTE--THE FATIGUE LIFE DISTRIBUTION--
C              GOES FROM 0 TO INFINITY
C              HAS MEAN = MU = 1
C              HAS STANDARD DEVIATION = MU*GAMMA*SQRT(1+(5/4)*GAMMA**2)
C              HAS SHAPE PARAMETER = GAMMA
C              IS NEAR-SYMMETRIC AND MODERATE-TAILED FOR SMALL GAMMA
C              IS HIGHLY-SKEWED AND LONG-TAILED FOR LARGE GAMMA
C              APPROACHES NORMALITY AS GAMMA APPROACHES 0
C     NOTE--TO OBTAIN THE PPF FOR GENERAL MU,
C           COMPUTE THE PPF FOR X AROUND 1, AND THEN
C           SIMPLY SCALE UP THE HORIZONTAL AXIS X BY THE DESIRED MU
C           AS IN Y2 = MU*Y
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION CUMULATIVE HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD
C             FUNCTION VALUE FOR THE FATIGUE LIFE DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = GAMMA
C             AND WITH LOCATION PARAMETER = 1
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--SAM SAUNDERS TALK, MAY 1990
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98.4
C     ORIGINAL VERSION--APRIL     1998.
C     UPDATED         --JULY      1999.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DTERM1
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.LE.0)GOTO50
      IF(X.LT.0.0)GOTO55
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,51)
   51 FORMAT('***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ',
     1'ARGUMENT TO THE FLCHA SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)GAMMA
   52 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',
     1E15.8,' *****')
      CALL DPWRST('XXX','BUG ')
      HAZ=0.0
      GOTO9000
   55 CONTINUE
      WRITE(ICOUT,56)
   56 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ',
     1'ARGUMENT TO THE FLCHA SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,57)X
   57 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',
     1E15.8,' *****')
      CALL DPWRST('XXX','BUG ')
      HAZ=0.0
      GOTO9000
   90 CONTINUE
C
      IF(X.EQ.0.0)THEN
        HAZ=0.0
      ELSEIF(X.GT.0.0)THEN
CCCCC    CALL FLCDF(X,GAMMA,CDF)
         DX=DBLE(X)
         DGAMMA=DBLE(GAMMA)
         DTERM1=(DSQRT(DX)-DSQRT(1.0D0/DX))/DGAMMA 
         CALL NODCDF(DTERM1,DCDF)
         DCDF=1.0D0-DCDF
         IF(DCDF.GT.0.0D0)THEN
           HAZ=REAL(-DLOG(DCDF))
         ELSE
           WRITE(ICOUT,162)X
  162    FORMAT('***** FOR THE VALUE OF THE ARGUMENT ',
     1   E15.8,' THE CDF IS ESSENTIALLY 1, HAZARD SET TO 0.')
         CALL DPWRST('XXX','BUG ')
         HAZ=0.0
         ENDIF
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE FLHAZ(X,GAMMA,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE FATIGUE LIFE DISTRIBUTION
C              WITH SHAPE PARAMETER = GAMMA
C              AND LOCATION PARAMETER = 1.
C              THE FATIGUE LIFE DISTRIBUTION IS "HALF WAY BETWEEN"
C              THE INVERSE GAUSSIAN DISTRIBUTION AND
C              THE RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION.
C     NOTE--THE FATIGUE LIFE DISTRIBUTION HAS--
C              FLPDF(X,GAMMA) = (IGPDF(X,GAMMA)+RIGPDF(X,GAMMA)) / 2
C                             = ((1+X)/2)*IGPDF(X,GAMMA)
C              FLCDF(X,GAMMA) = (IGCDF(X,GAMMA)+RIGCDF(X,GAMMA)) / 2
C                             = NORCDF((1/GAMMA)*(SQRT(X)-SQRT(1/X)))
C              FLPPF(P,GAMMA) = (SEE FLPPF.FOR)
C     NOTE--THE FATIGUE LIFE DISTRIBUTION--
C              GOES FROM 0 TO INFINITY
C              HAS MEAN = MU = 1
C              HAS STANDARD DEVIATION = MU*GAMMA*SQRT(1+(5/4)*GAMMA**2)
C              HAS SHAPE PARAMETER = GAMMA
C              IS NEAR-SYMMETRIC AND MODERATE-TAILED FOR SMALL GAMMA
C              IS HIGHLY-SKEWED AND LONG-TAILED FOR LARGE GAMMA
C              APPROACHES NORMALITY AS GAMMA APPROACHES 0
C     NOTE--TO OBTAIN THE PPF FOR GENERAL MU,
C           COMPUTE THE PPF FOR X AROUND 1, AND THEN
C           SIMPLY SCALE UP THE HORIZONTAL AXIS X BY THE DESIRED MU
C           AS IN Y2 = MU*Y
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C                                (ALSO = COEF. OF VARIATION)
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION HAZARD
C             FUNCTION VALUE FOR THE FATIGUE LIFE DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = GAMMA
C             AND WITH LOCATION PARAMETER = 1
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--SAM SAUNDERS TALK, MAY 1990
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98.4
C     ORIGINAL VERSION--APRIL     1998.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DPDF
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.LE.0)GOTO50
      IF(X.LT.0.0)GOTO55
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,51)
   51 FORMAT('***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ',
     1'ARGUMENT TO THE FLHAZ SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)GAMMA
   52 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',
     1E15.8,' *****')
      CALL DPWRST('XXX','BUG ')
      HAZ=0.0
      GOTO9000
   55 CONTINUE
      WRITE(ICOUT,56)
   56 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ',
     1'ARGUMENT TO THE FLHAZ SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,57)X
   57 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',
     1E15.8,' *****')
      CALL DPWRST('XXX','BUG ')
      HAZ=0.0
      GOTO9000
   90 CONTINUE
C
      IF(X.EQ.0.0)THEN
        HAZ=0.0
      ELSEIF(X.GT.0.0)THEN
CCCCC    CALL FLCDF(X,GAMMA,CDF)
CCCCC    CDF=1.0-CDF
         DX=DBLE(X)
         DGAMMA=DBLE(GAMMA)
         DTERM1=(DSQRT(DX)-DSQRT(1.0D0/DX))/DGAMMA 
         CALL NODCDF(DTERM1,DCDF)
         DCDF=1.0D0-DCDF
         IF(DCDF.GT.0.0D0)THEN
CCCCC      CALL FLPDF(X,GAMMA,PDF)
           DTERM1=DLOG(DSQRT(DX)+DSQRT(1.0D0/DX))
           DTERM2=DLOG(2.0D0*DX*DGAMMA)
           DTERM3=(DSQRT(DX)-DSQRT(1.0D0/DX))/DGAMMA
           CALL NODPDF(DTERM3,DTERM4)
           IF(DTERM4.LE.0.0D0)THEN
             DPDF=0.0D0
           ELSE
             DTERM4=DLOG(DTERM4)
             DPDF=DEXP(DTERM1-DTERM2+DTERM4)
           ENDIF
           HAZ=REAL(DPDF/DCDF)
         ELSE
           WRITE(ICOUT,162)X
  162    FORMAT('***** FOR THE VALUE OF THE ARGUMENT ',
     1   E15.8,' THE CDF IS ESSENTIALLY 1, HAZARD SET TO 0.')
         CALL DPWRST('XXX','BUG ')
         HAZ=0.0
         ENDIF
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE FLFUN (N, X, FVEC, IFLAG, XDATA, NOBS)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              FATIGUE LIFE MAXIMUM LIKELIHOOD EQUATIONS.
C
C              THE MAXIMUM LIKELIHOOD ESTIMATE OF BETA IS THE
C              POSITIVE ROOT OF:
C
C                 BHAT**2 - BHAT*{2*H+K(BHAT)} + H*{TBAR+K(BHAT)}=0
C
C              WITH
C
C                  H=1/[N*SUM[i=1 to N][1/X(i)]
C                  TBAR = SUM[i=1 to N][X(i)]/N
C                  K(BHAT) = 1/[N*SUM[i=1 to N][1/(BHAT+X(i))]
C
C              AND
C
C                  AHAT = 2*SQRT[0.5*(TBAR/BHAT + BHAT/H) - 1]
C
C              FLFUN IS CALLED BY DNSQE ROUTINE FOR SOLVING
C              SIMULTANEOUS NONLINEAR EQUATIONS.  NOTE THAT THE
C              CALLING SEQUENCE DID NOT ACCOMODATE A DATA ARRAY
C              (AND ASSCIATED NUMBER OF OBSERVATIONS), SO THESE WERE
C              ADDED TO THE CALL LIST.
C     EXAMPLE--FATIGUE LIFE MAXIMUM LIKELIHOOD Y
C     REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994).  "CONTINUOUS
C                UNIVARIATE DISTRIBUTIONS: VOLUME 2", SECOND EDITION,
C                JOHN WILEY, PP.  651-658.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/3
C     ORIGINAL VERSION--MARCH     2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DX1
      DOUBLE PRECISION DX2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION TBAR
      DOUBLE PRECISION H
      DOUBLE PRECISION DK
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      DBETA=X(1)
      DN=DBLE(NOBS)
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
C
      DO200I=1,NOBS
        DX=DBLE(XDATA(I))
        DSUM1=DSUM1 + DX
        DSUM2=DSUM2 + 1.0D0/DX
        DSUM3=DSUM3 + 1.0D0/(DX + DBETA)
  200 CONTINUE
      TBAR=DSUM1/DN
      H=DN/DSUM2
      DK=DN/DSUM3
      FVEC(1)=DBETA**2 - DBETA*(2.0D0*H + DK) + H*(TBAR+DK)
C
      RETURN
      END
      SUBROUTINE FLPDF(X,GAMMA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE FATIGUE LIFE DISTRIBUTION
C              WITH SHAPE PARAMETER = GAMMA
C              AND LOCATION PARAMETER = 1.
C              THE FATIGUE LIFE DISTRIBUTION IS "HALF WAY BETWEEN"
C              THE INVERSE GAUSSIAN DISTRIBUTION AND
C              THE RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION.
C     NOTE--THE FATIGUE LIFE DISTRIBUTION HAS--
C              FLPDF(X,GAMMA) = (IGPDF(X,GAMMA)+RIGPDF(X,GAMMA)) / 2
C                             = ((1+X)/2)*IGPDF(X,GAMMA)
C              FLCDF(X,GAMMA) = (IGCDF(X,GAMMA)+RIGCDF(X,GAMMA)) / 2
C                             = NORCDF((1/GAMMA)*(SQRT(X)-SQRT(1/X)))
C              FLPPF(P,GAMMA) = (SEE FLPPF.FOR)
C     NOTE--THE FATIGUE LIFE DISTRIBUTION--
C              GOES FROM 0 TO INFINITY
C              HAS MEAN = MU = 1
C              HAS STANDARD DEVIATION = MU*GAMMA*SQRT(1+(5/4)*GAMMA**2)
C              HAS SHAPE PARAMETER = GAMMA
C              IS NEAR-SYMMETRIC AND MODERATE-TAILED FOR SMALL GAMMA
C              IS HIGHLY-SKEWED AND LONG-TAILED FOR LARGE GAMMA
C              APPROACHES NORMALITY AS GAMMA APPROACHES 0
C     NOTE--TO OBTAIN THE PPF FOR GENERAL MU,
C           COMPUTE THE PPF FOR X AROUND 1, AND THEN
C           SIMPLY SCALE UP THE HORIZONTAL AXIS X BY THE DESIRED MU
C           AS IN Y2 = MU*Y
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C                                (ALSO = COEF. OF VARIATION)
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE FATIGUE LIFE DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = GAMMA
C             AND WITH SCALE PARAMETER = 1
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--SAM SAUNDERS TALK, MAY 1990
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --JULY      1999. USE DIFFERENT FORMULA
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DPDF
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.LE.0)GOTO50
      IF(X.LT.0.0)GOTO55
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,51)
   51 FORMAT('***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ',
     1'ARGUMENT TO THE WFPDF SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)GAMMA
   52 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',
     1E15.8,' *****')
      CALL DPWRST('XXX','BUG ')
      PDF=0.0
      GOTO9000
   55 CONTINUE
      WRITE(ICOUT,56)
   56 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ',
     1'ARGUMENT TO THE WFPDF SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,57)X
   57 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',
     1E15.8,' *****')
      CALL DPWRST('XXX','BUG ')
      PDF=0.0
      GOTO9000
   90 CONTINUE
C
      IF(X.EQ.0.0)GOTO1100
      GOTO1200
C
 1100 CONTINUE
      PDF=0.0
      GOTO9000
C
 1200 CONTINUE
C
CCCCC JULY 1999.  USE DIFFERENT FORMULA
CCCCC CALL IGPDF(X,GAMMA,PDF1)
CCCCC CALL RIGPDF(X,GAMMA,PDF2)
C
      DX=DBLE(X)
      DGAMMA=DBLE(GAMMA)
      DTERM1=DLOG(DSQRT(DX)+DSQRT(1.0D0/DX))
      DTERM2=DLOG(2.0D0*DX*DGAMMA)
      DTERM3=(DSQRT(DX)-DSQRT(1.0D0/DX))/DGAMMA
      CALL NODPDF(DTERM3,DTERM4)
      IF(DTERM4.LE.0.0D0)THEN
        PDF=0.0
        GOTO9000
      ENDIF
      DTERM4=DLOG(DTERM4)
      DPDF=DEXP(DTERM1-DTERM2+DTERM4)
      PDF=REAL(DPDF)
CCCCC PDF=(PDF1+PDF2)/2.0
CCCCC ARG1=(X**0.5+X**1.5)/(2.0*GAMMA)
CCCCC ARG2=(1.0/GAMMA)
CCCCC ARG3=SQRT(X)-1.0/SQRT(X)
CCCCC ARG4=ARG2*ARG3
CCCCC CALL NORPDF(ARG4,PDFN)
CCCCC PDF=ARG1*PDFN
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE FLPPF(P,GAMMA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE FATIGUE LIFE DISTRIBUTION
C              WITH SHAPE PARAMETER = GAMMA
C              AND LOCATION PARAMETER = 1.
C              THE FATIGUE LIFE DISTRIBUTION IS "HALF WAY BETWEEN"
C              THE INVERSE GAUSSIAN DISTRIBUTION AND
C              THE RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION.
C     NOTE--THE FATIGUE LIFE DISTRIBUTION HAS--
C              FLPDF(X,GAMMA) = (IGPDF(X,GAMMA)+RIGPDF(X,GAMMA)) / 2
C                             = ((1+X)/2)*IGPDF(X,GAMMA)
C              FLCDF(X,GAMMA) = (IGCDF(X,GAMMA)+RIGCDF(X,GAMMA)) / 2
C                             = NORCDF((1/GAMMA)*(SQRT(X)-SQRT(1/X)))
C              FLPPF(P,GAMMA) = (SEE BELOW)
C     NOTE--THE FATIGUE LIFE DISTRIBUTION--
C              GOES FROM 0 TO INFINITY
C              HAS MEAN = MU = 1
C              HAS STANDARD DEVIATION = MU*GAMMA*SQRT(1+(5/4)*GAMMA**2)
C              HAS SHAPE PARAMETER = GAMMA
C              IS NEAR-SYMMETRIC AND MODERATE-TAILED FOR SMALL GAMMA
C              IS HIGHLY-SKEWED AND LONG-TAILED FOR LARGE GAMMA
C              APPROACHES NORMALITY AS GAMMA APPROACHES 0
C     NOTE--TO OBTAIN THE PPF FOR GENERAL MU,
C           COMPUTE THE PPF FOR X AROUND 1, AND THEN
C           SIMPLY SCALE UP THE HORIZONTAL AXIS X BY THE DESIRED MU
C           AS IN Y2 = MU*Y
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C                                (ALSO = COEF. OF VARIATION)
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE INVERSE GAUSSIAN DISRIBUTION
C             WITH SHAPE PARAMETER GAMMA
C             AND SCALE PARAMETER 1
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN
C                   0.0 (INCLUSIVELY) AND 1.0 (EXCLUSIVELY).
C                 --GAMMA SHOULD BE POSITIVE
C     OTHER DATAPAC   SUBROUTINES NEEDED--IGCDF, NORCDF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--SAM SAUNDERS TALK, MAY 1990
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--90.6
C     ORIGINAL VERSION--MAY       1990.
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.LE.0)GOTO50
      IF(P.LT.0.0.OR.P.GE.1.0)GOTO60
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,51)
   51 FORMAT('***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ',
     1'ARGUMENT TO THE FLPPF SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)GAMMA
   52 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',
     1E15.8,' *****')
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      GOTO9000
   60 CONTINUE
      WRITE(ICOUT,61)
   61 FORMAT('***** FATAL ERROR--THE FIRST  INPUT ARGUMENT ',
     1'TO THE FLPPF SUBROUTINE ',
     1'IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)P
   62 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',
     1E15.8,' *****')
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      GOTO9000
   90 CONTINUE
C
      CALL NORPPF(P,PPFN)
      C=GAMMA*PPFN
C
      C2=C+SQRT(C*C+4.0)
CCCCC C3=C2/2.0
CCCCC PPF=C3**2
      PPF=0.25*(C2*C2)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE FLRAN(N,GAMMA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE FATIGUE LIFE DISTRIBUTION
C              WITH SHAPE PARAMETER VALUE = GAMMA
C              AND LOCATION PARAMETER MU = 1.
C              THE PROTOTYPE FATIGUE LIFE DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              RIGPDF(X,GAMMA) = ???
C                     WITH MU = 1
C     NOTE--THE FATIGUE LIFE DISTRIBUTION--
C              GOES FROM 0 TO INFINITY
C              HAS MEAN = MU = 1
C              HAS STANDARD DEVIATION =
C              HAS SHAPE PARAMETER = GAMMA
C              IS HIGHLY-SKEWED AND LONG-TAILED FOR SMALL GAMMA???
C              IS SYMMETRIC AND MODERATE-TAILED FOR LARGE GAMMA???
C              APPROACHES NORMALITY AS GAMMA APPROACHES INFINITY???
C     NOTE--TO OBTAIN THE PDF FOR GENERAL MU,
C           COMPUTE THE PDF FOR X AROUND 1, AND THEN
C           SIMPLY SCALE UP THE HORIZONTAL AXIS X BY THE DESIRED MU
C           AS IN Y2 = MU*Y
C              F(X) = GAMMA * (X**(GAMMA-1)) * EXP(-(X**GAMMA)).
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE OF THE
C                                TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE FATIGUE LIFE DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE HEREIN.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ
C               --SAM SAUNDERS
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--90.6
C     ORIGINAL VERSION--MAY       1990.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      IF(GAMMA.LE.0.0)GOTO60
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   60 WRITE(ICOUT,15)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)GAMMA
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE FIRST  INPUT ARGUMENT ',
     1'TO THE FLRAN SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT ',
     1'TO THE FLRAN SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,
     1' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,
     1' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N FATIGUE LIFE DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
      XTEMP=X(I)
      CALL FLPPF(XTEMP,GAMMA,X(I))
  100 CONTINUE
C
      RETURN
      END
      REAL FUNCTION FMINDP(AX,BX,F,TOL)
C
C   NOTE: ADDED TO DATAPLOT 12/2003.  USE THIS ROUTINE FOR INTERNAL
C         DATAPLOT USE.  THE DPOPT2 ROUTINE IS ESSENTIALLY A DATAPLOT
C         ADAPTATION OF FMIN THAT IMPLEMENTS "LET A = OPTIMIZE ..."
C         COMMANDS.  IT IS MORE EFFICIENT FOR INTERNAL USE TO USE
C         FMIN EXPLICITLY (AVOID OVERHEAD OF FUNCTION PARSING, ETC.)
C
C   NOTE: MARCH 2005.  RENAME TO FMINDP TO AVOID NAME CONFLICT ON MAC OSX.
C
C***BEGIN PROLOGUE  FMIN
C***DATE WRITTEN   730101  (YYMMDD)
C***REVISION DATE  730101  (YYMMDD) 
C***CATEGORY NO.  G1A2
C***KEYWORDS  ONE-DIMENSIONAL MINIMIZATION, UNIMODAL FUNCTION
C***AUTHOR  BRENT, R.
C***PURPOSE  An approximation to the point where F attains a minimum on
C            the interval (AX,BX) is determined as the value of the 
C            function FMIN.
C***DESCRIPTION
C
C     From the book, "Numerical Methods and Software" by
C                D. Kahaner, C. Moler, S. Nash
C                Prentice Hall, 1988
C
C     The method used is a combination of golden section search and
C     successive parabolic interpolation.  Convergence is never much 
C     slower than that for a Fibonacci search.  If F has a continuous 
C     second derivative which is positive at the minimum (which is not
C     at AX or BX), then convergence is superlinear, and usually of the 
C     order of about 1.324....
C
C     The function F is never evaluated at two points closer together
C     than EPS*ABS(FMIN) + (TOL/3), where EPS is approximately the 
C     square root of the relative machine precision.  If F is a unimodal
C     function and the computed values of F are always unimodal when
C     separated by at least EPS*ABS(XSTAR) + (TOL/3), then FMIN 
C     approximates the abcissa of the global minimum of F on the 
C     interval AX,BX with an error less than 3*EPS*ABS(FMIN) + TOL.  
C     If F is not unimodal, then FMIN may approximate a local, but 
C     perhaps non-global, minimum to the same accuracy.
C
C     This function subprogram is a slightly modified version of the
C     ALGOL 60 procedure LOCALMIN given in Richard Brent, Algorithms for
C     Minimization Without Derivatives, Prentice-Hall, Inc. (1973).
C
C INPUT PARAMETERS
C
C  AX    (real)  left endpoint of initial interval
C  BX    (real) right endpoint of initial interval
C  F     Real function of the form REAL FUNCTION F(X) which evaluates 
C          F(X)  for any  X in the interval  (AX,BX)
C        Must be declared EXTERNAL in calling routine.
C  TOL   (real) desired length of the interval of uncertainty of the 
C        final result ( .ge. 0.0)
C
C
C OUTPUT PARAMETERS
C
C FMIN   abcissa approximating the minimizer of F
C AX     lower bound for minimizer
C BX     upper bound for minimizer
C
C***REFERENCES  RICHARD BRENT, ALGORITHMS FOR MINIMIZATION WITHOUT 
C                 DERIVATIVES, PRENTICE-HALL, INC. (1973).
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  FMIN
      REAL  AX,BX,F,TOL
      REAL  A,B,C,D,E,EPS,XM,P,Q,R,TOL1,TOL2,U,V,W
      REAL  FU,FV,FW,FX,X
      REAL  ABS,SQRT,SIGN
C***FIRST EXECUTABLE STATEMENT  FMIN
      C = 0.5*(3. - SQRT(5.0))
C
C  C is the squared inverse of the golden ratio
C
C  EPS is approximately the square root of the relative machine
C  precision.
C
      EPS = 1.0
   10 EPS = EPS/2.0
      TOL1 = 1.0 + EPS
      IF (TOL1 .GT. 1.0) GO TO 10
      EPS = SQRT(EPS)
C
C  initialization
C
      A = AX
      B = BX
      V = A + C*(B - A)
      W = V
      X = V
      E = 0.0
      FX = F(X)
      FV = FX
      FW = FX
C
C  main loop starts here
C
   20 XM = 0.5*(A + B)
      TOL1 = EPS*ABS(X) + TOL/3.0
      TOL2 = 2.0*TOL1
C
C  check stopping criterion
C
      IF (ABS(X - XM) .LE. (TOL2 - 0.5*(B - A))) GO TO 90
C
C is golden-section necessary
C
      IF (ABS(E) .LE. TOL1) GO TO 40
C
C  fit parabola
C
      R = (X - W)*(FX - FV)
      Q = (X - V)*(FX - FW)
      P = (X - V)*Q - (X - W)*R
      Q = 2.0*(Q - R)
      IF (Q .GT. 0.0) P = -P
      Q = ABS(Q)
      R = E
      E = D
C
C  is parabola acceptable
C
   30 IF (ABS(P) .GE. ABS(0.5*Q*R)) GO TO 40
      IF (P .LE. Q*(A - X)) GO TO 40
      IF (P .GE. Q*(B - X)) GO TO 40
C
C  a parabolic interpolation step
C
      D = P/Q
      U = X + D
C
C  F must not be evaluated too close to AX or BX
C
      IF ((U - A) .LT. TOL2) D = SIGN(TOL1, XM - X)
      IF ((B - U) .LT. TOL2) D = SIGN(TOL1, XM - X)
      GO TO 50
C
C  a golden-section step
C
   40 IF (X .GE. XM) E = A - X
      IF (X .LT. XM) E = B - X
      D = C*E
C
C  F must not be evaluated too close to X
C
   50 IF (ABS(D) .GE. TOL1) U = X + D
      IF (ABS(D) .LT. TOL1) U = X + SIGN(TOL1, D)
      FU = F(U)
C
C  update  A, B, V, W, and X
C
      IF (FU .GT. FX) GO TO 60
      IF (U .GE. X) A = X
      IF (U .LT. X) B = X
      V = W
      FV = FW
      W = X
      FW = FX
      X = U
      FX = FU
      GO TO 20
   60 IF (U .LT. X) A = U
      IF (U .GE. X) B = U
      IF (FU .LE. FW) GO TO 70
      IF (W .EQ. X) GO TO 70
      IF (FU .LE. FV) GO TO 80
      IF (V .EQ. X) GO TO 80
      IF (V .EQ. W) GO TO 80
      GO TO 20
   70 V = W
      FV = FW
      W = U
      FW = FU
      GO TO 20
   80 V = U
      FV = FU
      GO TO 20
C
C  end of main loop
C
   90 FMINDP = X
      RETURN
      END
      FUNCTION FNALPH(X,NOBS,BETA,XGM)
C
C COMPUTE MLE FOR SCALE PARAMETER (ALPHA)
C    XGM IS THE GEOMETRIC MEAN OF THE X'S
C
      DOUBLE PRECISION SUMZ
      DIMENSION X(*)
C
      RN=FLOAT(NOBS)
C
      SUMZ=0.0D0
      DO 20 I=1,NOBS
        SUMZ=SUMZ+DBLE((X(I)/XGM)**BETA)
   20 CONTINUE
C
      FNALPH=XGM*(SNGL(SUMZ)/RN)**(1./BETA)
C
      RETURN
      END
      FUNCTION FNALP2(X,NOBS,IR,GAMMA)
C
C    COMPUTE MLE FOR SCALE PARAMETER (ALPHA)
C    THIS IS FOR THE TYPE 2 CENSORED CASE.
C    XGM IS THE GEOMETRIC MEAN OF THE X'S
C
      DOUBLE PRECISION DG
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
      DIMENSION X(*)
C
      DG=DBLE(GAMMA)
C
      DSUM1=0.0D0
      DO 20 I=1,IR
        DSUM1=DSUM1+(DBLE(X(I))**DG)
   20 CONTINUE
      DTERM1=DSUM1/DBLE(IR)
      DTERM2=DBLE(NOBS-IR)*DBLE(X(I))**DG
      DTERM3=(DTERM1 + DTERM2)**(1.0D0/DG)
C
      FNALP2=REAL(DTERM3)
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION FNCMVT(N, W)
*     
*     Integrand subroutine
*
      INTEGER N, NUIN, INFIN(*), INFIS
      DOUBLE PRECISION W(*), LOWER(*), UPPER(*), CORREL(*), D, E
      INTEGER NL, IJ, I, J, NU
      PARAMETER ( NL = 20 )
      DOUBLE PRECISION COV((NL*(NL+1))/2), A(NL), B(NL), Y(NL)
      INTEGER INFI(NL)
      DOUBLE PRECISION PROD, D1, E1, DI, EI, SUM, STDINV, YD, UI, MVTNIT
      SAVE NU, D1, E1, A, B, INFI, COV
      DI = D1
      EI = E1
      PROD = EI - DI
      IJ = 1
      YD = 1.0D0
      DO 100 I = 1, N
         UI = STDINV( NU+I-1, DI + W(I)*( EI - DI ) )
         Y(I) = UI/YD
         YD = YD/SQRT( 1.0D0 + ( UI - 1.0D0 )*( UI + 1.0D0 )/
     +        DBLE( NU + I ) )
         SUM = 0.0D0
         DO 200 J = 1, I
            IJ = IJ + 1
            SUM = SUM + COV(IJ)*Y(J)
  200    CONTINUE
         IJ = IJ + 1
         CALL MVTLMS( NU+I, ( A(I+1) - SUM )*YD, ( B(I+1) - SUM )*YD, 
     &                INFI(I+1), DI, EI ) 
         PROD = PROD*( EI - DI )
  100 CONTINUE
      FNCMVT = PROD
      RETURN 
*
*     Entry point for intialization
*
      ENTRY MVTNIT( N, NUIN, CORREL, LOWER, UPPER, INFIN, INFIS, D, E ) 
      MVTNIT = 0.0D0
*
*     Initialization and computation of covariance matrix Cholesky factor
*
      CALL MVTSRT( N, NUIN, LOWER, UPPER, CORREL, INFIN, Y, INFIS, 
     &             A, B, INFI, COV, D, E )
      NU = NUIN
      D1 = D
      E1 = E
C
      RETURN
      END
      SUBROUTINE FNRCDF(X,U,SD,CDF)
C
C     NOTE--FOLDED-NORMAL PDF IS:
C              FNRPDF(X,U,S,P) = NORPDF((X-U)/S) + NORPDF((X+U)/S))
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/9
C     ORIGINAL VERSION--SEPTEMBER 1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
C
      IF(X.LT.0.0)THEN
        CDF=0.0
        GOTO9999
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)SD
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE FNRCDF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
  201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ',
     1       'PARAMETER IS NON-POSITIVE.')
  203 FORMAT('      THE VALUE IS ',E15.7)
C
      TERM1=(X-U)/SD
      CALL NORCDF(TERM1,TERM2)
      TERM2=TERM2
      TERM3=(-X-U)/SD
      CALL NORCDF(TERM3,TERM4)
      TERM4=TERM4
      CDF=TERM2-TERM4
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE FNRFUN (N, X, FVEC, IFLAG, XDATA, NOBS)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              FOLDED NORMAL MAXIMUM LIKELIHOOD
C              EQUATIONS.
C
C              MU**2 + SIGMA**2 - SUM[i=1 to n][X(i)**2]/N
C
C              MU - SUM[i=1 to n][X(i)*TANH(LOC*X(i)/SIGMA**2)]/N
C
C              WITH LOC AND SCALE DENOTING THE SHAPE PARAMETERS.
C
C              CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS
C              NONLINEAR EQUATIONS.  NOTE THAT THE CALLING SEQUENCE
C              DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF
C              OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST.
C     EXAMPLE--FOLDED NORMAL MAXIMUM LIKELIHOOD Y
C     REFERENCE--"CONTINUOUS UNIVARIATE DISTRIBUTIONS-VVOLUME II",
C                SECOND EDITION, JOHNSON, KOTZ, AND BALAKRISHNAN,
C                1994, WILEY, P. 454.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/3
C     ORIGINAL VERSION--MARCH     2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DLOC
      DOUBLE PRECISION DSCALE
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      DLOC=X(1)
      DSCALE=X(2)
      DN=DBLE(NOBS)
C
      DSUM1=0.0D0
      DSUM2=0.0D0
C
      DO200I=1,NOBS
        DX=DBLE(XDATA(I))
        DSUM1=DSUM1 + DX*DX
        DSUM2=DSUM2 + DX*TANH(DLOC*DX/DSCALE)
  200 CONTINUE
C
      FVEC(1)=DLOC*DLOC + DSCALE - (DSUM1/DN)
      FVEC(2)=DLOC - (DSUM2/DN)
C
      RETURN
      END
      SUBROUTINE FNRPDF(X,U,SD,PDF)
C
C     NOTE--FOLDED-NORMAL PDF IS:
C              FNRPDF(X,U,S)=(1/S)*(NORPDF((X-U)/S) + NORPDF((X+U)/S)))
C           WHERE NORPDF IS THE PDF OF THE STANDARD NORMAL DISTRIBUTION
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/4
C     ORIGINAL VERSION--APRIL     1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)SD
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE FNRPDF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
  201 FORMAT('***** FATAL DIAGNOSTIC--THE STANDARD DEVIATION ',
     1       'PARAMETER IS NON-POSITIVE.')
  203 FORMAT('      THE VALUE IS ',E15.7)
C
      TERM1=(X-U)/SD
      CALL NORPDF(TERM1,TERM2)
      TERM2=TERM2/SD
      TERM3=(X+U)/SD
      CALL NORPDF(TERM3,TERM4)
      TERM4=TERM4/SD
      PDF=TERM2+TERM4
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE FNRPPF(P,U,SD,PPF)
C
C     PURPOSE   --PERCENT POINT FUNCTION FOR THE FOLDED NORMAL
C                 DISTRIBUTION.  USES A BISECTION METHOD.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/9
C     ORIGINAL VERSION--SEPTEMBER 1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DU
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DSD
      DOUBLE PRECISION DPI
      DOUBLE PRECISION DSDF
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION EPS
      DOUBLE PRECISION SIG
      DOUBLE PRECISION ZERO
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION XL
      DOUBLE PRECISION XR
      DOUBLE PRECISION XINC
      DOUBLE PRECISION X
      DOUBLE PRECISION FXL
      DOUBLE PRECISION FXR
      DOUBLE PRECISION P1
      DOUBLE PRECISION FCS
      DOUBLE PRECISION XRML
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION CDFL
      DOUBLE PRECISION CDFR
C
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA DPI /3.14159265358979D0/
      DATA EPS /0.00001D0/
      DATA SIG /1.0D-6/
      DATA ZERO /0.0D0/
      DATA MAXIT /5000/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GE.1.0)GOTO50
      IF(SD.LE.0.0)GOTO70
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   70 WRITE(ICOUT,35)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)SD
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      GOTO9999
C
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1' FNRPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
   35 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1' FNRPPF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
   90 CONTINUE
C
C  NOVEMBER 1995.  IF P IS 0, PPF IS ZERO.  HANDLE THIS TRIVIAL CASE.
C
      IF(P.EQ.0.0)THEN
        PPF=0.0
        GOTO9999
      ENDIF
C
C  FIND BRACKETING INTERVAL.
C  AFTER SUCCESSFULLY FIND BRACKETING INTERVAL, THEN SWITCH TO 
C  MORE EFFICIENT BISECTION METHOD.
C
C  CALCULATE MEAN AND STANDARD DEVIATION OF FOLDED NORMAL
C
      DU=DBLE(U)
      DSD=DBLE(SD)
      DP=DBLE(P)
      DTERM1=DEXP(-DU**2/(2.0D0*DSD**2))
      DTERM2=DSQRT(2.D0/DPI)
      DTERM3=-DU/DSD
      CALL NODCDF(DTERM3,DTERM4)
      DMEAN=DTERM2*DSD*DTERM1 + DU*(1.D0-2.D0*DTERM4)
      DSDF=DMEAN**2 + DU*DU + DSD*DSD
C
      XL=DMEAN
      XINC=DSDF
      IF(XINC.LT.1.0D0)XINC=1.0D0
      ICOUNT=0
C
   91 CONTINUE
      XR=XL+XINC
      IF(XL.LE.0.0D0)XL=0.0D0
      IF(XR.LE.0.0D0)XR=XL+1.0D0
CCCCC CALL FNRCDF(XL,U,SD,CDFL)
C
      DTERM1=(XL-DU)/DSD
      CALL NODCDF(DTERM1,DTERM2)
      DTERM3=(-XL-DU)/DSD
      CALL NODCDF(DTERM3,DTERM4)
      CDFL=DTERM2-DTERM4
C
CCCCC CALL FNRCDF(XR,U,SD,CDFR)
C
      DTERM1=(XR-DU)/DSD
      CALL NODCDF(DTERM1,DTERM2)
      DTERM3=(-XR-DU)/DSD
      CALL NODCDF(DTERM3,DTERM4)
      CDFR=DTERM2-DTERM4
C
      IF(CDFL.LT.DP .AND. CDFR.LT.DP)THEN
        XL=XR
      ELSEIF(CDFL.GT.DP .AND. CDFR.GT.DP)THEN
        XL=XL-XINC
      ELSE
        GOTO99
      ENDIF
      ICOUNT=ICOUNT+1
      IF(ICOUNT.GT.MAXIT)THEN
        WRITE(ICOUT,96)
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
   96 FORMAT('***** FATAL ERROR--FNRPPF UNABLE TO FIND BRACKETING ',
     *       'INTERVAL. *****')
      GOTO91
C
C  BISECTION METHOD
C
   99 CONTINUE
      IC = 0
      FXL = -DP
      FXR = 1.0D0 - DP
  105 CONTINUE
      X = (XL+XR)*0.5D0
CCCCC CALL FNRCDF(X,U,SD,CDF)
C
      DTERM1=(X-DU)/DSD
      CALL NODCDF(DTERM1,DTERM2)
      DTERM3=(-X-DU)/DSD
      CALL NODCDF(DTERM3,DTERM4)
      DCDF=DTERM2-DTERM4
C
      P1=DCDF
      PPF=X
      FCS = P1 - DP
      IF(FCS*FXL.GT.ZERO)GOTO110
      XR = X
      FXR = FCS 
      GOTO115
  110 CONTINUE
      XL = X
      FXL = FCS
  115 CONTINUE
      XRML = XR - XL
      IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999
      IC = IC + 1
      IF(IC.LE.MAXIT)GOTO105
      WRITE(ICOUT,130)
      CALL DPWRST('XXX','BUG ')
  130 FORMAT('***** FATAL ERROR--FNRPPF ROUTINE DID NOT CONVERGE. ***')
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE FNRRAN(N,U,SD,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE FOLDED NORMAL DISTRIBUTION.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                       U      = MEAN OF PARENT NORMAL DISTRIBUTION
C                       SD     = STANDARD DEVIATION OF PARENT NORMAL
C                                DISTRIBUTION
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE FOLDED-NORMAL DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG, SQRT, SIN, COS.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 14-15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 53, 59, 81, 83.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--95/10
C     ORIGINAL VERSION--OCTOBER   1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(2)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA PI/3.14159265359/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'FNRRAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C     THEN GENERATE 2 ADDITIONAL UNIFORM (0,1) RANDOM NUMBERS
C     (TO BE USED BELOW IN FORMING THE N-TH NORMAL
C     RANDOM NUMBER WHEN THE DESIRED SAMPLE SIZE N
C     HAPPENS TO BE ODD).
C
      CALL UNIRAN(N,ISEED,X)
      CALL UNIRAN(2,ISEED,Y)
C
C     GENERATE N NORMAL RANDOM NUMBERS
C     USING THE BOX-MULLER METHOD.
C
      DO200I=1,N,2
      IP1=I+1
      U1=X(I)
      IF(I.EQ.N)GOTO210
      U2=X(IP1)
      GOTO220
  210 U2=Y(2)
  220 ARG1=-2.0*ALOG(U1)
      ARG2=2.0*PI*U2
      SQRT1=SQRT(ARG1)
      Z1=SQRT1*COS(ARG2)
      Z2=SQRT1*SIN(ARG2)
      X(I)=Z1
      IF(I.EQ.N)GOTO200
      X(IP1)=Z2
  200 CONTINUE
C
C     GENERATE N FOLDED NORMAL RANDOM NUMBERS
C     USING THE DEFINITION THAT
C     A FOLDED NORMAL VARIATE
C     EQUALS THE ABSOLUTE VALUE OF A NORMAL VARIATE WITH
C     MEAN U AND STANDARD DEVIATION SD.
C
      DO400I=1,N
      X(I)=SD*X(I)+U
      IF(X(I).LT.0.0)X(I)=-X(I)
  400 CONTINUE
C
      RETURN
      END
      SUBROUTINE FTCDF(X,NU,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE FOLDED T DISTRIBUTION
C              WITH INTEGER DEGREES OF FREEDOM PARAMETER = NU.
C              THIS DISTRIBUTION IS DEFINED FOR NON-NEGATIVE X
C              AND IS THE ABSOLUTE VALUE OF THE STUDENT'S T
C              DISTRIBUTION.
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED
C              FROM THE CORRESPONDING T CDF FUNCTION
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --NU     = THE INTEGER NUMBER OF DEGREES
C                                OF FREEDOM.
C                                NU SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE CDF FOR THE FODLED T DISTRIBUTION
C             WITH DEGREES OF FREEDOM PARAMETER = NU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NU SHOULD BE A POSITIVE INTEGER VARIABLE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--TCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS, VOLUME 2, 1994, PAGE 403,
C                 JOHN WILEY.
C                 PAGES 132-134.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--NOVEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(NU.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)NU
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE FOLDED T CDF SUBROUTINE IS NEGATIVE *****')
   15 FORMAT('***** FATAL ERROR--THE DEGREES OF FREEDOM ARGUMENT ',
     1       'TO THE FOLDED T CDF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CALL TCDF(X,NU,CDF)
      CDF=2.0*CDF - 1.0
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE FTPDF(X,NU,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE FOLDED T DISTRIBUTION
C              WITH INTEGER DEGREES OF FREEDOM PARAMETER = NU.
C              THIS DISTRIBUTION IS DEFINED FOR NON-NEGATIVE X
C              AND IS THE ABSOLUTE VALUE OF THE STUDENT'S T
C              DISTRIBUTION.
C              THE PROBABILITY DENSITY FUNCTION IS GIVEN
C              IN THE REFERENCES BELOW.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --NU     = THE INTEGER NUMBER OF DEGREES
C                                OF FREEDOM.
C                                NU SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE FODLED T DISTRIBUTION
C             WITH DEGREES OF FREEDOM PARAMETER = NU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NU SHOULD BE A POSITIVE INTEGER VARIABLE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--TPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS, VOLUME 2, 1994, PAGE 403,
C                 JOHN WILEY.
C                 PAGES 132-134.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--NOVEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(NU.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)NU
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE FOLDED T PDF SUBROUTINE IS NEGATIVE *****')
   15 FORMAT('***** FATAL ERROR--THE DEGREES OF FREEDOM ARGUMENT ',
     1       'TO THE FOLDED T PDF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CALL TPDF(X,NU,PDF)
      PDF=2.0*PDF
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE FTPPF(P,NU,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE FOLDED T DISTRIBUTION
C              WITH INTEGER DEGREES OF FREEDOM PARAMETER = NU.
C              THIS DISTRIBUTION IS DEFINED FOR NON-NEGATIVE X
C              AND IS THE ABSOLUTE VALUE OF THE STUDENT'S T
C              DISTRIBUTION.
C              THE PERCENT POINT FUNCTION IS COMPUTED
C              FROM THE CORRESPONDING T PPF FUNCTION
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE (BETWEEN
C                                0.0 AND 1.0) AT WHICH THE PERCENT
C                                POINT FUNCTION IS TO BE EVALUATED.
C                     --NU     = THE INTEGER NUMBER OF DEGREES
C                                OF FREEDOM.
C                                NU SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE FODLED T DISTRIBUTION
C             WITH DEGREES OF FREEDOM PARAMETER = NU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NU SHOULD BE A POSITIVE INTEGER VARIABLE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--TPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS, VOLUME 2, 1994, PAGE 403,
C                 JOHN WILEY.
C                 PAGES 132-134.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--NOVEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0 .OR. P.GE.1.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
      IF(NU.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)NU
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE FOLDED T PPF SUBROUTINE IS OUTSIDE THE ')
    6 FORMAT('      ALLOWABLE (0,1] INTERVAL.')
   15 FORMAT('***** FATAL ERROR--THE DEGREES OF FREEDOM ARGUMENT ',
     1       'TO THE FOLDED T PPF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      ARG=(1.0+P)/2.0
      CALL TPPF(ARG,NU,PPF)
      IF(PPF.LE.0.0)PPF=0.0
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE FTRAN(N,NU,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE FOLDED T DISTRIBUTION
C              WITH INTEGER DEGREES OF FREEDOM PARAMETER = NU.
C              THE FOLDED T IS THE ABSOLUTE VALUE OF THE
C              STUDENT'S T DISTRIBUTION.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --NU     = THE INTEGER DEGREES OF FREEDOM
C                                (PARAMETER) FOR THE FOLDED T
C                                DISTRIBUTION.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE FOLDED T DISTRIBUTION
C             WITH DEGREES OF FREEDOM PARAMETER = NU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --NU SHOULD BE A POSITIVE INTEGER VARIABLE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG, SQRT, SIN, COS.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS, VOLUME 2", 1994,
C                 JOHN WILEY, P. 403.
C                 ALGORITHM IS TO FIND T RANDOM NUMBERS AND THEN
C                 TAKE ABSOLUTE VALUE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2003.11
C     ORIGINAL VERSION--NOVEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(2),Z(2)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA PI/3.14159265359/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(NU.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)NU
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    5 FORMAT('***** FATAL ERROR--FOR THE FOLDED T DISTRIBUTION, THE',
     1'REQUESTED NUMBER OF RANDOM NUMBERS WAS NON-POSITIVE.')
   15 FORMAT('***** FATAL ERROR--FOR THE FOLDED T DISTRIBUTION, THE',
     1'SPECIFIED SHAPE PARAMETER WAS NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N STUDENT'S T RANDOM NUMBERS
C     USING THE DEFINITION THAT
C     A STUDENT'S T VARIATE WITH NU DEGREES OF FREEDOM
C     EQUALS A NORMAL VARIATE DIVIDED BY
C     A STANDARDIZED CHI VARIATE
C     (WHERE THE LATTER EQUALS SQRT(CHI-SQUARED/NU).
C     FIRST GENERATE A NORMAL RANDOM NUMBER,
C     THEN GENERATE A STANDARDIZED CHI RANDOM NUMBER,
C     THEN FORM THE RATIO OF THE FIRST DIVIDED BY
C     THE SECOND.
C
C     FOR FOLDED T, TAKE THE ABSOLUTE VALUE.
C
      ANU=NU
      DO100I=1,N
C
      CALL UNIRAN(2,ISEED,Y)
      ARG1=-2.0*ALOG(Y(1))
      ARG2=2.0*PI*Y(2)
      ZNORM=(SQRT(ARG1))*(COS(ARG2))
C
      SUM=0.0
      DO200J=1,NU,2
      CALL UNIRAN(2,ISEED,Y)
      ARG1=-2.0*ALOG(Y(1))
      ARG2=2.0*PI*Y(2)
      Z(1)=(SQRT(ARG1))*(COS(ARG2))
      Z(2)=(SQRT(ARG1))*(SIN(ARG2))
      SUM=SUM+Z(1)*Z(1)
      IF(J.EQ.NU)GOTO200
      SUM=SUM+Z(2)*Z(2)
  200 CONTINUE
C
      X(I)=ABS(ZNORM/SQRT(SUM/ANU))
C
  100 CONTINUE
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE FORSLV(NR,N,A,X,B)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C SOLVE  AX=B  WHERE A IS LOWER TRIANGULAR MATRIX
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF PROBLEM
C A(N,N)       --> LOWER TRIANGULAR MATRIX (PRESERVED)
C X(N)        <--  SOLUTION VECTOR
C B(N)         --> RIGHT-HAND SIDE VECTOR
C
C NOTE
C ----
C IF B IS NO LONGER REQUIRED BY CALLING ROUTINE,
C THEN VECTORS B AND X MAY SHARE THE SAME STORAGE.
C
      DIMENSION A(NR,1),X(N),B(N)
C
C SOLVE LX=B. (FOREWARD SOLVE)
C
      X(1)=B(1)/A(1,1)
      IF(N.EQ.1) RETURN
      DO 20 I=2,N
        SUM=0.0
        IM1=I-1
        DO 10 J=1,IM1
          SUM=SUM+A(I,J)*X(J)
   10   CONTINUE
        X(I)=(B(I)-SUM)/A(I,I)
   20 CONTINUE
      RETURN
      END
      SUBROUTINE FOUTRA(Y1,Y2,YC,SCRTCH,N1,ITCASE,IWRITE,Y12,IFTEXP,
     1IFTORD,
CCCCC AUGUST 1995.  ADD YC AND SCRTCH (FOR CMLIB ROUTINE) ARGUMENT.
CCCCC SUBROUTINE FOUTRA(Y1,Y2,N1,ITCASE,IWRITE,Y12,IFTEXP,
     1Y3,Y4,N3,IBUGA3,IERROR)
C
C     PURPOSE--CARRY OUT FOURIER TRANSFORM-TYPE OPERATIONS
C              OF THE COMPLEX DATA IN Y1 AND Y2.
C
C     OPERATIONS--FOURIER TRANSFORM
C                 INVERSE FOURIER TRANSFORM
C                 FFT
C                 INVERSE FFT
C
C     EXAMPLES--LET T1 T2 = FOURIER TRANSFORM Y1 Y2
C               LET Y1 Y2 = INVERSE FOURIER TRANSFORM T1 T2
C               LET T1 T2 = FFT Y1 Y2
C               LET Y1 Y2 = INVERSE FFT T1 T2
C     INPUT  ARGUMENTS--Y1 (REAL PART)       Y2 (IMAGINARY PART)
C     OUTPUT ARGUMENTS--Y3 (REAL PART)       Y4 (IMAGINARY PART)
C
C     NOTE--FOR THE FOURIER TRANSFORM AND THE FFT--
C              Y3(1) = A0 =
C              Y3(2) = A1
C              Y3(3) = A2
C              .
C              .
C              .
C              Y3(N) = A(N-1) =
C
C              Y4(1) = B0 =
C              Y4(2) = B1
C              Y4(3) = B2
C              .
C              .
C              .
C              Y4(N) = B(N-1) =
C
C     NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT VECTORS Y3(.) AND Y4(.)
C           BEING IDENTICAL TO THE INPUT VECTORS Y1(.) AND Y2(.).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/5
C     ORIGINAL VERSION--APRIL    1987.
C     UPDATED--SEPTEMBER 1987   (FFT AND INVERSE FFT)
C     UPDATED--AUGUST    1995   REPLACE NUMERICAL RECIPES ROUTINE
C                               WITH CMLIB ROUTINE.  ALSO, GO FROM
C                               1 TO N RATHER THAN -N/2 TO N/2.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ITCASE
      CHARACTER*4 IWRITE
      CHARACTER*4 IFTEXP
CCCCC AUGUST 1995.  ADD FOLLOWING LINE
      CHARACTER*4 IFTORD
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
      CHARACTER*4 ITCAS2
C
C-----DOUBLE PRECISION STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DPI
      DOUBLE PRECISION DN1
      DOUBLE PRECISION DI
      DOUBLE PRECISION DK
      DOUBLE PRECISION DKM1
      DOUBLE PRECISION DOMEGA
      DOUBLE PRECISION DY1K
      DOUBLE PRECISION DY2K
C
      DOUBLE PRECISION DC
      DOUBLE PRECISION DS
      DOUBLE PRECISION DTCR
      DOUBLE PRECISION DTSR
      DOUBLE PRECISION DTCI
      DOUBLE PRECISION DTSI
      DOUBLE PRECISION DSUMCR
      DOUBLE PRECISION DSUMSR
      DOUBLE PRECISION DSUMCI
      DOUBLE PRECISION DSUMSI
CCCCC AUGUST 1995.  ADD FOLLOWING LINE
      COMPLEX YC
C
C---------------------------------------------------------------------
C
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION Y3(*)
      DIMENSION Y4(*)
      DIMENSION Y12(*)
CCCCC AUGUST 1995.  ADD FOLLOWING 2 LINES.
      DIMENSION YC(*)
      DIMENSION SCRTCH(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='FOUT'
      ISUBN2='RA  '
C
      IERROR='NO'
C
      DN1=(-999.0D0)
      ITCAS2='-999'
C
      DPI=3.14159265358979D0
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF FOUTRA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3,ITCASE,IWRITE
   52 FORMAT('IBUGA3,ITCASE,IWRITE = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IFTEXP
   53 FORMAT('IFTEXP = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)N1
   54 FORMAT('N1 = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N1
      WRITE(ICOUT,56)I,Y1(I),Y2(I)
   56 FORMAT('I,Y1(I),Y2(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               ***************************************************
C               **  CARRY OUT FOURIER TRANSFORM-TYPE OPERATIONS  **
C               ***************************************************
C
C               ********************************************
C               **  STEP 11--                             **
C               **  CHECK NUMBER OF INPUT OBSERVATIONS.   **
C               ********************************************
C
      IF(N1.LT.1)GOTO1100
      GOTO1190
C
 1100 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1151)
 1151 FORMAT('***** ERROR IN FOUTRA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1152)
 1152 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1153)
 1153 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      IF(ITCASE.EQ.'FOUT'.OR.ITCASE.EQ.'FOU1')WRITE(ICOUT,1154)
 1154 FORMAT('      THE FOURIER TRANSFORM IS TO BE ',
     1'COMPUTED')
      IF(ITCASE.EQ.'FOUT'.OR.ITCASE.EQ.'FOU1')CALL DPWRST('XXX','BUG ')
      IF(ITCASE.EQ.'IFOU'.OR.ITCASE.EQ.'IFO1')WRITE(ICOUT,1155)
 1155 FORMAT('      THE INVERSE FOURIER TRANSFORM IS TO BE ',
     1'COMPUTED')
      IF(ITCASE.EQ.'IFOU'.OR.ITCASE.EQ.'IFO1')CALL DPWRST('XXX','BUG ')
      IF(ITCASE.EQ.'FFT'.OR.ITCASE.EQ.'FFT1')WRITE(ICOUT,1156)
 1156 FORMAT('      THE FFT IS TO BE ',
     1'COMPUTED')
      IF(ITCASE.EQ.'FFT'.OR.ITCASE.EQ.'FFT1')CALL DPWRST('XXX','BUG ')
      IF(ITCASE.EQ.'IFFT'.OR.ITCASE.EQ.'IFF1')WRITE(ICOUT,1157)
 1157 FORMAT('      THE INVERSE FFT IS TO BE ',
     1'COMPUTED')
      IF(ITCASE.EQ.'IFFT'.OR.ITCASE.EQ.'IFF1')CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)
 1181 FORMAT('      MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)
 1182 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1183)N1
 1183 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1190 CONTINUE
C
C               *********************************
C               **  STEP 12--                  **
C               **  BRANCH TO THE PROPER CASE  **
C               *********************************
C
      IF(ITCASE.EQ.'FOUT')GOTO2100
      IF(ITCASE.EQ.'FOU1')GOTO2100
      IF(ITCASE.EQ.'IFOU')GOTO2100
      IF(ITCASE.EQ.'IFO1')GOTO2100
      IF(ITCASE.EQ.'FFT')GOTO2300
      IF(ITCASE.EQ.'FFT1')GOTO2300
      IF(ITCASE.EQ.'IFFT')GOTO2300
      IF(ITCASE.EQ.'IFF1')GOTO2300
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1211)
 1211 FORMAT('***** INTERNAL ERROR IN FOUTRA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1212)
 1212 FORMAT('      ITCASE NOT EQUAL TO')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1213)
 1213 FORMAT('      FOUT, FOU1, IFOU, IFO1')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1214)
 1214 FORMAT('      FFT, FFT1, IFFT, OR IFF1')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1215)
 1215 FORMAT('      ITCASE = ',A4)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
C               ************************************************
C               **  STEP 21--                                 **
C               **  TREAT THE FOURIER TRANSFORM         CASE  **
C               **  TREAT THE INVERSE FOURIER TRANSFORM CASE  **
C               **  BY OPERATING ON THE REAL AND              **
C               **  COMPLEX PARTS,                            **
C               **  BY TAKING                                 **
C               **     COSINE TRANSFORM OF REAL      PART     **
C               **     SINE   TRANSFORM OF REAL      PART     **
C               **     COSINE TRANSFORM OF IMAGINARY PART     **
C               **     SINE   TRANSFORM OF IMAGINARY PART,    **
C               **  AND BY COMBINING PROPERLY.                **
C               ************************************************
C
 2100 CONTINUE
C
      DN1=N1
CCCCC AUGUST 1995.  FOLLOWING DEFINITION FOR FOURIER EXPONENT
CCCCC "+" CASE.  FOURIER EXPONENT "-" CASE USES OPPOSSITE
CCCCC DEFINITIONS.
CCCCC IF(ITCASE.EQ.'FOUT')ITCAS2='FT'
CCCCC IF(ITCASE.EQ.'FOU1')ITCAS2='FT'
CCCCC IF(ITCASE.EQ.'IFOU')ITCAS2='IFT'
CCCCC IF(ITCASE.EQ.'IFO1')ITCAS2='IFT'
      IF(IFTEXP.EQ.'+')THEN
        IF(ITCASE.EQ.'FOUT')ITCAS2='FT'
        IF(ITCASE.EQ.'FOU1')ITCAS2='FT'
        IF(ITCASE.EQ.'IFOU')ITCAS2='IFT'
        IF(ITCASE.EQ.'IFO1')ITCAS2='IFT'
      ELSE
        IF(ITCASE.EQ.'FOUT')ITCAS2='IFT'
        IF(ITCASE.EQ.'FOU1')ITCAS2='IFT'
        IF(ITCASE.EQ.'IFOU')ITCAS2='FT'
        IF(ITCASE.EQ.'IFO1')ITCAS2='FT'
      ENDIF
C
      L=N1/2
      M=0
      DO2110IP1=1,N1
      I=IP1-1
      L=L+1
      IF(L.GT.N1)L=1
      M=M+1
      DI=I
      DOMEGA=2.0*DPI*(DI/DN1)
      DSUMCR=0.0
      DSUMSR=0.0
      DSUMCI=0.0
      DSUMSI=0.0
C
CCCCC AUGUST 1995.  FOR 'STANDARD' ORDERING.
      IF(IFTORD.EQ.'STAN')THEN
        M2=0
      ELSE
        IF(ITCAS2.EQ.'FT')M2=0
        IF(ITCAS2.EQ.'IFT')M2=N1/2
      ENDIF
CCCCC END CHANGE
      DO2120K=1,N1
      DK=K
      DKM1=DK-1.0D0
      M2=M2+1
      IF(M2.GT.N1)M2=1
      DY1K=Y1(M2)
      DY2K=Y2(M2)
CCCCC DSUMCR=DSUMCR+DY1K*DCOS(DOMEGA*DKM1)
CCCCC DSUMSR=DSUMSR+DY1K*DSIN(DOMEGA*DKM1)
CCCCC DSUMCI=DSUMCI+DY2K*DCOS(DOMEGA*DKM1)
CCCCC DSUMSI=DSUMSI+DY2K*DSIN(DOMEGA*DKM1)
      DC=DCOS(DOMEGA*DKM1)
      DS=DSIN(DOMEGA*DKM1)
      DTCR=DC*DY1K
      DTSR=DS*DY1K
      DTCI=DC*DY2K
      DTSI=DS*DY2K
      DSUMCR=DSUMCR+DTCR
      DSUMSR=DSUMSR+DTSR
      DSUMCI=DSUMCI+DTCI
      DSUMSI=DSUMSI+DTSI
      IF(IBUGA3.EQ.'OFF')GOTO779
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,774)I,K,M2,DY1K,DY2K
  774 FORMAT('I,K,M2,DY1K,DY2K = ',3I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,775)DKM1,DOMEGA,DC,DS
  775 FORMAT('DKM1,DOMEGA,DC,DS = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,776)DTCR,DTSR,DTCI,DTSI
  776 FORMAT('DTCR,DTSR,DTCI,DTSI = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,778)DSUMCR,DSUMSR,DSUMCI,DSUMSI
  778 FORMAT('DSUMCR,DSUMSR,DSUMCI,DSUMSI = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
  779 CONTINUE
 2120 CONTINUE
C
C     THE FOLLOWING COMMENTED OUT CODE IS APPROPRIATE
C     IF THE FORWARD TRANSFORM IS DEFINED WITH A - IN THE EXPONENT
C     (AS IS THE USUAL CLASSIC DEFINITION)
C
CCCCC IF(ITCAS2.EQ.'FT')Y3(L)=DSUMCR+DSUMSI
CCCCC IF(ITCAS2.EQ.'FT')Y4(L)=DSUMCI-DSUMSR
CCCCC IF(ITCAS2.EQ.'IFT')Y3(M)=(DSUMCR-DSUMSI)/DN1
CCCCC IF(ITCAS2.EQ.'IFT')Y4(M)=(DSUMCI+DSUMSR)/DN1
C
C     THE FOLLOWING CODE IS APPROPRIATE
C     IF THE FORWARD TRANSFORM IS DEFINED WITH A + IN THE EXPONENT
C     (AS DEFINED BY PRESS ET AL (NUMERICAL RECIPES))
C
CCCCC AUGUST 1995.  FIX FOR STANDARD ORDERING
      IF(IFTORD.EQ.'STAN')THEN
        IF(ITCAS2.EQ.'FT')Y3(M)=DSUMCR-DSUMSI
        IF(ITCAS2.EQ.'FT')Y4(M)=DSUMCI+DSUMSR
        IF(ITCAS2.EQ.'IFT')Y3(M)=(DSUMCR+DSUMSI)/DN1
        IF(ITCAS2.EQ.'IFT')Y4(M)=(DSUMCI-DSUMSR)/DN1
      ELSE
        IF(ITCAS2.EQ.'FT')Y3(L)=DSUMCR-DSUMSI
        IF(ITCAS2.EQ.'FT')Y4(L)=DSUMCI+DSUMSR
        IF(ITCAS2.EQ.'IFT')Y3(M)=(DSUMCR+DSUMSI)/DN1
        IF(ITCAS2.EQ.'IFT')Y4(M)=(DSUMCI-DSUMSR)/DN1
      ENDIF
C
      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,2121)I,IP1,L,M,DN1,DI
 2121 FORMAT('I,IP1,L,M,DN1,DI = ',4I8,2D15.7)
      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,2122)DSUMCR,DSUMSR,DSUMCI,DSUMSI
 2122 FORMAT('DSUMCR,DSUMSR,DSUMCI,DSUMSI = ',4D15.7)
      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,999)
      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
 2110 CONTINUE
      N3=N1
      GOTO9000
C
C               ************************************************
C               **  STEP 23--                                 **
C               **  TREAT THE FFT                       CASE  **
C               **  TREAT THE INVERSE FFT               CASE  **
C               **  (NOTE--N1 IS ASSUMED TO BE A POWER OF 2)  **
C               ************************************************
C
 2300 CONTINUE
C
      AN1=N1
      NN2=2*N1
C
CCCCC AUGUST 1995.  SET ISIGN CORRECTLY
      IF(IFTEXP.EQ.'+')THEN
        ISIGN=1
        IF(ITCASE.EQ.'IFFT')ISIGN=(-1)
        IF(ITCASE.EQ.'IFF1')ISIGN=(-1)
      ELSE
        ISIGN=(-1)
        IF(ITCASE.EQ.'IFFT')ISIGN=1
        IF(ITCASE.EQ.'IFF1')ISIGN=1
      ENDIF
CCCCC IF(ITCASE.EQ.'FFT')GOTO2310
CCCCC IF(ITCASE.EQ.'FFT1')GOTO2310
CCCCC AUGUST 1995.  BE CONSISTENT IN SCALING!!!
CCCCC ADD FOLLOWING 2 LINES
CCCCC IF(ITCASE.EQ.'IFFT')GOTO2310
CCCCC IF(ITCASE.EQ.'IFF1')GOTO2310
CCCCC GOTO2319
C2310 CONTINUE
CCCCC J=(-1)
CCCCC DO2311I=1,N1
CCCCC J=J+2
CCCCC JP1=J+1
CCCCC Y12(J)=Y1(I)
CCCCC Y12(JP1)=Y2(I)
C2311 CONTINUE
C2319 CONTINUE
C
CCCCC AUGUST 1995.  BE CONSISTENT IN SCALING!!!
CCCCC COMMENT OUT FOLLOWING 2 LINES
CCCCC IF(ITCASE.EQ.'IFFT')GOTO2320
CCCCC IF(ITCASE.EQ.'IFF1')GOTO2320
CCCCC GOTO2329
C2320 CONTINUE
CCCCC J=N1-1
CCCCC DO2321I=1,N1
CCCCC J=J+2
CCCCC IF(J.GT.NN2)J=1
CCCCC JP1=J+1
CCCCC Y12(J)=Y1(I)
CCCCC Y12(JP1)=Y2(I)
C2321 CONTINUE
C2329 CONTINUE
C
CCCCC AUGUST 1995.  FOR CMLIB ROUTINE, STORE IN A COMPLEX ARRAY.
CCCCC NOTE THAT DATAPLOT ORDER IMPLIES (-N/2,N/2) RATHER THAN
CCCCC (1,N).
C
      IF(IFTORD.EQ.'STAN')THEN
        DO2360I=1,N1
        YC(I)=CMPLX(Y1(I),Y2(I))
 2360   CONTINUE
      ELSE
        IF(ISIGN.LT.0)THEN
          J=N1/2
          DO2363I=1,N1
          J=J+1
          IF(J.GT.N1)J=1
          YC(J)=CMPLX(Y1(I),Y2(I))
 2363     CONTINUE
        ELSE
          DO2368I=1,N1
          YC(I)=CMPLX(Y1(I),Y2(I))
 2368     CONTINUE
        ENDIF
      ENDIF
C
CCCCC AUGUST 1995.  DETERMINE VALUE OF ISIGN BEFORE CREATE INPUT FILE.
CCCCC ISIGN=1
CCCCC IF(ITCASE.EQ.'IFFT')ISIGN=(-1)
CCCCC IF(ITCASE.EQ.'IFF1')ISIGN=(-1)
CCCCC IF(IFTEXP.EQ.'+')ISIGN=(-ISIGN)
C
      IF(IBUGA3.EQ.'OFF')GOTO2333
      DO2331I=1,NN2
CCCCC WRITE(ICOUT,2332)I,NN2,Y12(I)
      WRITE(ICOUT,2332)I,NN2,YC(I)
 2332 FORMAT('I,NN2,YC(I) = ',2I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 2331 CONTINUE
 2333 CONTINUE
C
CCCCC CALL FOUR1(Y12,NN2,ISIGN)
CCCCC AUGUST 1995.  REPLACE NUMERICAL RECIPES ROUTINES WITH
CCCCC CMLIB ROUTINE.
CCCCC CALL FOUR1(Y12,N1,ISIGN)
      CALL CFFTI(N1,SCRTCH)
      IF(ISIGN.LT.0)THEN
        CALL CFFTF(N1,YC,SCRTCH)
      ELSE
        CALL CFFTB(N1,YC,SCRTCH)
      ENDIF
C
      IF(IBUGA3.EQ.'OFF')GOTO2337
      DO2335I=1,NN2
CCCCC WRITE(ICOUT,2336)I,NN2,Y12(I)
      WRITE(ICOUT,2336)I,NN2,YC(I)
 2336 FORMAT('I,NN2,YC(I) = ',2I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 2335 CONTINUE
 2337 CONTINUE
C
CCCCC AUGUST 1995.  BE CONSISTENT IN SCALING!!!
CCCCC COMMENT OUT FOLLOWING 2 LINES
CCCCC IF(ITCASE.EQ.'FFT')GOTO2340
CCCCC IF(ITCASE.EQ.'FFT1')GOTO2340
CCCCC GOTO2349
C2340 CONTINUE
CCCCC J=N1-1
CCCCC DO2341I=1,N1
CCCCC J=J+2
CCCCC IF(J.GT.NN2)J=1
CCCCC JP1=J+1
CCCCC Y3(I)=Y12(J)
CCCCC Y4(I)=Y12(JP1)
C2341 CONTINUE
C2349 CONTINUE
C
CCCCC AUGUST 1995.  BE CONSISTENT IN SCALING!!!
CCCCC ADD FOLLOWING 2 LINES
CCCCC IF(ITCASE.EQ.'FFT')GOTO2350
CCCCC IF(ITCASE.EQ.'FFT1')GOTO2350
CCCCC IF(ITCASE.EQ.'IFFT')GOTO2350
CCCCC IF(ITCASE.EQ.'IFF1')GOTO2350
CCCCC GOTO2359
 2350 CONTINUE
CCCCC J=(-1)
CCCCC AUGUST 1995.  RETURN THE DATA IN "STANDARD" ORDER OR IN
CCCCC "DATAPLOT" ORDER.  "STANDARD" ORDER IS WHAT IS RETURNED BY
CCCCC CFFTF AND CFFTB ROUTINES
      IF(IFTORD.EQ.'STAN')THEN
        DO2351I=1,N1
CCCCC   J=J+2
CCCCC   JP1=J+1
CCCCC   Y3(I)=Y12(J)/AN1
CCCCC   Y4(I)=Y12(JP1)/AN1
        Y3(I)=REAL(YC(I))
        Y4(I)=AIMAG(YC(I))
 2351   CONTINUE
      ELSE
        IF(ISIGN.GT.0)THEN
          J=N1/2
          DO2356I=1,N1
          J=J+1
          IF(J.GT.N1)J=1
          Y3(I)=REAL(YC(J))
          Y4(I)=AIMAG(YC(J))
 2356     CONTINUE
        ELSE
          DO2358I=1,N1
          Y3(I)=REAL(YC(I))
          Y4(I)=AIMAG(YC(I))
 2358     CONTINUE
        ENDIF
      ENDIF
 2359 CONTINUE
C
C
CCCCC AUGUST 1995.  DIVIDE BY N IF ISIGN IS -1
      IF(ISIGN.LT.0.0)THEN
        DO2370I=1,N1
        Y3(I)=Y3(I)/AN1
        Y4(I)=Y4(I)/AN1
 2370   CONTINUE
      ENDIF
C
      N3=N1
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF FOUTRA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,ITCASE,IWRITE,IERROR
 9012 FORMAT('IBUGA3,ITCASE,IWRITE,IERROR = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IFTEXP
 9013 FORMAT('IFTEXP = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)N1,N3,NN2,ISIGN,ITCAS2
 9014 FORMAT('N1,N3,NN2,ISIGN,ITCAS2 = ',4I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,N1
      WRITE(ICOUT,9016)I,Y1(I),Y2(I),Y3(I),Y4(I)
 9016 FORMAT('I,Y1(I),Y2(I),Y3(I),Y4(I) = ',I8,4E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
      DO9025I=1,NN2
      WRITE(ICOUT,9026)I,NN2,YC(I)
 9026 FORMAT('I,NN2,YC(I) = ',2I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9025 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE FPDF(X,NU1,NU2,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR F DISTRIBUTION
C              WITH INTEGER DEGREES OF FREEDOM PARAMETER = NU1 AND NU2.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X.
C              THE PROBABILITY DENSITY FUNCTION IS GIVEN
C              IN THE REFERENCES BELOW.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --NU1    = THE INTEGER NUMBER OF DEGREES
C                                OF FREEDOM.
C                                NU1 SHOULD BE POSITIVE.
C                     --NU2    = THE INTEGER NUMBER OF DEGREES
C                                OF FREEDOM.
C                                NU2 SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE STUDENT'S T DISTRIBUTION
C             WITH DEGREES OF FREEDOM PARAMETER = NU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NU1 AND NU2 SHOULD BE A POSITIVE INTEGER VARIABLE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DATAN.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHMATICS
C                 SERIES 55, 1964, PAGE 946, FORMULA 26.6.1.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES XXX.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--AUGUST    1977.
C     UPDATED         --NOVEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DNU1
      DOUBLE PRECISION DNU2
      DOUBLE PRECISION DNU1H
      DOUBLE PRECISION DNU2H
      DOUBLE PRECISION DNU12H
      DOUBLE PRECISION DGF1
      DOUBLE PRECISION DGF2
      DOUBLE PRECISION DGF12
      DOUBLE PRECISION DTERM
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
      DOUBLE PRECISION DCONST
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(NU1.LE.0)GOTO110
      GOTO119
  110 CONTINUE
      WRITE(ICOUT,115)
  115 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT ',
     1'TO THE   FPDF   SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)NU1
  117 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,
     1' *****')
      CALL DPWRST('XXX','BUG ')
      PDF=0.0
      GOTO9000
  119 CONTINUE
C
      IF(NU2.LE.0)GOTO120
      GOTO129
  120 CONTINUE
      WRITE(ICOUT,125)
  125 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT ',
     1'TO THE   FPDF   SUBROUTINE IS NON-POSITIVE *****')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,127)NU2
  127 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,
     1' *****')
      CALL DPWRST('XXX','BUG ')
      PDF=0.0
      GOTO9000
  129 CONTINUE
C
C               ****************************************************************
C               **  STEP 2--
C               **  COMPUTE THE CONSTANT = ((NU1**(NU1/2))*(NU2**(NU2/2))/(BETA(
C               ****************************************************************
C
      DX=X
      DNU1=NU1
      DNU2=NU2
      DNU1H=DNU1/2.0
      DNU2H=DNU2/2.0
C
      DTERM1=DNU1**DNU1H
      DTERM2=DNU2**DNU2H
      CALL DGAMMF(DNU1H,DGF1)
      CALL DGAMMF(DNU2H,DGF2)
      DNU12H=DNU1H+DNU2H
      CALL DGAMMF(DNU12H,DGF12)
      DTERM3=(DGF1*DGF2)/DGF12
      DCONST=(DTERM1*DTERM2)/DTERM3
C
C               ************************************
C               **  STEP 3--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      IF(DX.LE.0.0D0)PDF=0.0
      IF(DX.LE.0.0D0)GOTO9000
C
      DTERM4=DX**(DNU1H-1.0D0)
      DTERM5=(DNU2+DNU1*DX)**(-DNU1H-DNU2H)
      DTERM=DTERM4*DTERM5
      PDF=DCONST*DTERM
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE FPPF(P,NU1,NU2,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FOR THE F DISTRIBUTION
C              WITH INTEGER DEGREES OF FREEDOM
C              PARAMETERS = NU1 AND NU2.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X.
C              THE PROBABILITY DENSITY FUNCTION IS GIVEN
C              IN THE REFERENCES BELOW.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --NU1    = THE INTEGER DEGREES OF FREEDOM
C                                FOR THE NUMERATOR OF THE F RATIO.
C                                NU1 SHOULD BE POSITIVE.
C                     --NU2    = THE INTEGER DEGREES OF FREEDOM
C                                FOR THE DENOMINATOR OF THE F RATIO.
C                                NU2 SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE F DISTRIBUTION
C             WITH DEGREES OF FREEDOM
C             PARAMETERS = NU1 AND NU2.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN
C                   0.0 (INCLUSIVELY) AND 1.0 (EXCLUSIVELY).
C                 --NU1 SHOULD BE A POSITIVE INTEGER VARIABLE.
C                 --NU2 SHOULD BE A POSITIVE INTEGER VARIABLE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--FCDF, NORCDF, CHSCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DATAN.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGES 946-947,
C                 FORMULAE 26.6.4, 26.6.5, 26.6.8, AND 26.6.15.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGE 83, FORMULA 20,
C                 AND PAGE 84, THIRD FORMULA.
C               --PAULSON, AN APPROXIMATE NORMAILIZATION
C                 OF THE ANALYSIS OF VARIANCE DISTRIBUTION,
C                 ANNALS OF MATHEMATICAL STATISTICS, 1942,
C                 NUMBER 13, PAGES 233-135.
C               --SCHEFFE AND TUKEY, A FORMULA FOR SAMPLE SIZES
C                 FOR POPULATION TOLERANCE LIMITS, 1944,
C                 NUMBER 15, PAGE 217.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--MAY       1978.
C     UPDATED         --AUGUST    1979.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PPF=0.0
      IF(NU1.LE.0)GOTO50
      IF(NU2.LE.0)GOTO55
      IF(P.LT.0.0.OR.P.GE.1.0)GOTO60
      GOTO90
   50 WRITE(ICOUT,15)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)NU1
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   55 WRITE(ICOUT,23)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)NU2
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   60 WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'FPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'FPPF   SUBROUTINE IS NON-POSITIVE *****')
   23 FORMAT('***** FATAL ERROR--THE THIRD  INPUT ARGUMENT TO THE ',
     1'FCDF   SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      IBUG=0.0
C
      TOL=0.000001
      MAXIT=100
      XMIN=0.0
      XMAX=10.0**30
      XLOW=XMIN
      XUP=XMAX
C
      ANU1=NU1
      ANU2=NU2
C
      EXPF=0.5*((1.0/ANU2)-(1.0/ANU1))
      SDF=SQRT(0.5*((1.0/ANU2)+(1.0/ANU1)))
      CALL NORPPF(P,ZN)
      XN=EXPF+ZN*SDF
      XMID=EXP(2*XN)
      IF(IBUG.EQ.1)WRITE(ICOUT,101)XMID
  101 FORMAT('XMID = ',E15.7)
      IF(IBUG.EQ.1)CALL DPWRST('XXX','BUG ')
C
      IF(P.EQ.0.0)GOTO110
      GOTO190
  110 CONTINUE
      PPF=XMIN
      RETURN
  190 CONTINUE
C
      ICOUNT=0
C
  200 CONTINUE
      X=XMID
      CALL FCDF(X,NU1,NU2,PCALC)
      IF(PCALC.EQ.P)GOTO240
      IF(PCALC.GT.P)GOTO220
C
  210 CONTINUE
      XLOW=XMID
      X=XMID*2.0
      IF(X.GE.XUP)GOTO211
      XMID=X
      IF(IBUG.EQ.1)WRITE(ICOUT,101)XMID
      IF(IBUG.EQ.1)CALL DPWRST('XXX','BUG ')
      CALL FCDF(X,NU1,NU2,PCALC)
      IF(PCALC.EQ.P)GOTO240
      IF(PCALC.LT.P)GOTO210
      XUP=X
  211 CONTINUE
      XMID=(XLOW+XUP)/2.0
      IF(IBUG.EQ.1)WRITE(ICOUT,101)XMID
      IF(IBUG.EQ.1)CALL DPWRST('XXX','BUG ')
      GOTO230
C
  220 CONTINUE
      XUP=XMID
      X=XMID/2.0
      IF(X.LE.XLOW)GOTO221
      XMID=X
      IF(IBUG.EQ.1)WRITE(ICOUT,101)XMID
      IF(IBUG.EQ.1)CALL DPWRST('XXX','BUG ')
      CALL FCDF(X,NU1,NU2,PCALC)
      IF(PCALC.EQ.P)GOTO240
      IF(PCALC.GT.P)GOTO220
      XLOW=X
  221 CONTINUE
      XMID=(XLOW+XUP)/2.0
      IF(IBUG.EQ.1)WRITE(ICOUT,101)XMID
      IF(IBUG.EQ.1)CALL DPWRST('XXX','BUG ')
      GOTO230
C
  230 CONTINUE
      XDEL=ABS(XMID-XLOW)
      ICOUNT=ICOUNT+1
      IF(XDEL.LT.TOL.OR.ICOUNT.GT.MAXIT)GOTO240
      GOTO200
C
  240 CONTINUE
      PPF=XMID
C
      RETURN
      END
      SUBROUTINE FRACTA(X1,Y1,N1,IWRITE,
     1X2,Y2,N2,IBUGA3,IERROR)
C
C     PURPOSE--CARRY OUT FRACTAL GENERATION
C              OF THE DATA IN X1 AND Y1.
C
C     EXAMPLES--LET X1 Y1 = FRACTAL X2 Y2
C     INPUT  ARGUMENTS--X1 (X COOR)       Y1 (Y COOR)
C     OUTPUT ARGUMENTS--X2 (X COOR)       Y2 (Y COOR)
C
C     NOTE--FOR STEP 1 OF THE LOOP
C           (2 POINTS IN AND 5 POINTS OUT)
C           (1 LINE IN AND 4 LINES OUT)--
C
C            X2(1) = X1(1)
C            X2(2) = X1(1) + (1/3)DELX
C            X2(3) = X1(1) + (1/2)DELX - (SQRT(3)/6)DELY
C            X2(4) = X1(1) + (2/3)DELX
C            X2(5) = X1(2)
C
C            Y2(1) = Y1(1)
C            Y2(2) = Y1(1) + (1/3)DELY
C            Y2(3) = Y1(1) + (1/2)DELY + (SQRT(3)/6)DELX
C            Y2(4) = Y1(1) + (2/3)DELY
C            Y2(5) = Y1(2)
C
C     NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT VECTORS X2(.) AND Y2(.)
C           BEING IDENTICAL TO THE INPUT VECTORS X1(.) AND Y1(.).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--RUCKER. INFINITY AND THE MIND, PAGE 9.
C     VERSION NUMBER--88/10
C     ORIGINAL VERSION--JULY     1988.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X1(*)
      DIMENSION Y1(*)
      DIMENSION X2(*)
      DIMENSION Y2(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='FRAC'
      ISUBN2='TA  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF FRACTA--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,IWRITE
   52   FORMAT('IBUGA3,IWRITE = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,54)N1
   54   FORMAT('N1 = ',I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N1
        WRITE(ICOUT,56)I,X1(I),Y1(I)
   56   FORMAT('I,X1(I),Y1(I) = ',I8,2E15.7)
        CALL DPWRST('XXX','BUG ')
   55   CONTINUE
   90 CONTINUE
C
C                 *******************************************************
C                 **  CARRY OUT FOURIER FRACTAL-GENERATION OPERATIONS  **
C                 *******************************************************
C
C                 ********************************************
C                 **  STEP 11--                             **
C                 **  CHECK NUMBER OF INPUT OBSERVATIONS.   **
C                 ********************************************
C
        IF(N1.LT.2)GOTO1100
        GOTO1190
C
 1100 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1151)
 1151 FORMAT('***** ERROR IN FRACTA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1152)
 1152 FORMAT('        THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1153)
 1153 FORMAT('        IN THE VARIABLES FROM WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1154)
 1154 FORMAT('        THE AUGMENTED FRACTAL VARIABLE IS TO BE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)
 1181 FORMAT('        CREATED, MUST BE 2 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)
 1182 FORMAT('        SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1183)N1
 1183 FORMAT('        THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1190 CONTINUE
C
C                 ************************************************
C                 **  STEP 21--                                 **
C                 **  COMPUTE THE FRACTAL SET OF POINTS         **
C                 ************************************************
C
 2100 CONTINUE
C
      C=SQRT(3.0)/6.0
      N1M1=N1-1
      L=0
      DO2110I=1,N1M1
      IP1=I+1
      A1=X1(I)
      B1=Y1(I)
      A5=X1(IP1)
      B5=Y1(IP1)
      DELX=A5-A1
      DELY=B5-B1
      A2=A1+DELX/3
      A3=A1+DELX/2-C*DELY
      A4=A1+2*DELX/3
      B2=B1+DELY/3
      B3=B1+DELY/2+C*DELX
      B4=B1+2*DELY/3
      L=L+1
      X2(L)=A1
      Y2(L)=B1
      L=L+1
      X2(L)=A2
      Y2(L)=B2
      L=L+1
      X2(L)=A3
      Y2(L)=B3
      L=L+1
      X2(L)=A4
      Y2(L)=B4
      L=L+1
      X2(L)=A5
      Y2(L)=B5
 2110 CONTINUE
      N2=L
C
C                 *****************
C                 **  STEP 90--  **
C                 **  EXIT.      **
C                 *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END         OF FRACTA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IWRITE,IERROR
 9012 FORMAT('IBUGA3,IWRITE,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)N1,N2
 9014 FORMAT('N1,N2 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,N1
      WRITE(ICOUT,9016)I,X1(I),Y1(I)
 9016 FORMAT('I,X1(I),Y1(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
      DO9017I=1,N2
      WRITE(ICOUT,9018)I,X2(I),Y2(I)
 9018 FORMAT('I,X2(I),Y2(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9017 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE FRAN(N,ANU1,ANU2,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE F DISTRIBUTION
C              WITH INTEGER DEGREES OF FREEDOM
C              PARAMETERS = NU1 AND NU2.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X.
C              THE PROBABILITY DENSITY FUNCTION IS GIVEN
C              IN THE REFERENCES BELOW.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --NU1    = THE INTEGER DEGREES OF FREEDOM
C                                FOR THE NUMERATOR OF THE F RATIO.
C                     --NU2    = THE INTEGER DEGREES OF FREEDOM
C                                FOR THE DENOMINATOR OF THE F RATIO.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE F DISTRIBUTION
C             WITH DEGREES OF FREEDOM
C             PARAMETERS = NU1 AND NU2.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --NU1 SHOULD BE A POSITIVE INTEGER VARIABLE.
C                 --NU2 SHOULD BE A POSITIVE INTEGER VARIABLE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG, SQRT, SIN, COS.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--MOOD AND GRABLE, INTRODUCTION TO THE
C                 THEORY OF STATISTICS, 1963, PAGES 231-232.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 75-93.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 64.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MAY       2004. SUPPORT REAL VALUES FOR
C                                       DEGREES OF FREEDOM PARAMETERS
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 ICASE
C
      DIMENSION X(*)
      DIMENSION Y(2),Z(2)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA PI/3.14159265359/
      DATA EPS/0.00001/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      IF(ANU1.LE.0.0)GOTO60
      IF(ANU2.LE.0.0)GOTO65
      GOTO90
   50 WRITE(ICOUT,5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   60 WRITE(ICOUT,15)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)NU1
      CALL DPWRST('XXX','BUG ')
      RETURN
   65 WRITE(ICOUT,25)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)NU2
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1'FRAN   SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'FRAN   SUBROUTINE IS NON-POSITIVE *****')
   25 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1'FRAN   SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
   48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,' *****')
C
      NU1=INT(ANU1+0.1)
      ANU12=REAL(NU1)
      NU2=INT(ANU2+0.1)
      ANU22=REAL(NU2)
      IF(ABS(ANU1-ANU12).LE.EPS .AND. ABS(ANU2-ANU22).LE.EPS)THEN
        ICASE='INTE'
        IF(NU1.EQ.0 .OR. NU2.EQ.0)THEN
          ICASE='REAL'
        ENDIF
      ELSE
        ICASE='REAL'
      ENDIF
C
C     CASE 1: INTEGER DEGREES OF FREEDOM
C
      IF(ICASE.EQ.'INTE')THEN
C       GENERATE N F RANDOM NUMBERS
C       USING THE DEFINITION THAT
C       A F VARIATE WITH NU1 AND NU2 DEGREES OF FREEDOM
C       EQUALS (CHS1/NU1)/(CHS2/NU2)
C       WHERE CHS1 IS A CHI-SQUARED VARIATE
C       WITH NU1 DEGREES OF FREEDOM,
C       AND   CHS2 IS A CHI-SQUARED VARIATE
C       WITH NU2 DEGREES OF FREEDOM.
C       FIRST GENERATE UNIFORM (0,1) RANDOM NUMBERS,
C       THEN GENERATE NORMAL RANDOM NUMBERS,
C       THEN CHI-SQUARED RANDOM NUMBERS WITH NU1 DEGREES
C       OF FREEDOM,
C       THEN CHI-SQUARED RANDOM NUMBERS WITH NU2 DEGREES
C       OF FREEDOM,
C       AND THEN FINALLY THE F RANDOM NUMBER.
C
        ANU1=NU1
        ANU2=NU2
        DO100I=1,N
C
          SUM=0.0
          DO200J=1,NU1,2
            CALL UNIRAN(2,ISEED,Y)
            ARG1=-2.0*ALOG(Y(1))
            ARG2=2.0*PI*Y(2)
            Z(1)=(SQRT(ARG1))*(COS(ARG2))
            Z(2)=(SQRT(ARG1))*(SIN(ARG2))
            SUM=SUM+Z(1)*Z(1)
            IF(J.EQ.NU1)GOTO200
            SUM=SUM+Z(2)*Z(2)
  200     CONTINUE
          CHS1=SUM
C
          SUM=0.0
          DO300J=1,NU2,2
            CALL UNIRAN(2,ISEED,Y)
            ARG1=-2.0*ALOG(Y(1))
            ARG2=2.0*PI*Y(2)
            Z(1)=(SQRT(ARG1))*(COS(ARG2))
            Z(2)=(SQRT(ARG1))*(SIN(ARG2))
            SUM=SUM+Z(1)*Z(1)
            IF(J.EQ.NU2)GOTO300
            SUM=SUM+Z(2)*Z(2)
  300     CONTINUE
          CHS2=SUM
C
          X(I)=(CHS1/ANU1)/(CHS2/ANU2)
C
  100   CONTINUE
C
      ELSE
        P=ANU1/2.0
        Q=ANU2/2.0
        CALL BETRAN(N,P,Q,ISEED,X)
        DO500I=1,N
          ATEMP=X(I)
          X(I)=ANU2*ATEMP/(ANU1*(1.0-ATEMP))
  500   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE FREQUE(X,NX,D,ND,NUMVAR,IWRITE,
     1Y,NY,IBUGA3,IERROR)
C
C     PURPOSE--COMPUTE FREQUENCIES FOR SPECIFIED VALUES OF A VARIABLE
C              (OR IF NO VALUES SPECIFIED, COMPUTE FREQUENCIES
C              FOR DISTINCT VALUES OF A VARIABLE).
C     NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.)
C           BEING IDENTICAL TO THE INPUT VECTOR X(.).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--FEBRUARY  1979.
C     UPDATED         --APRIL     1979.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION D(*)
      DIMENSION Y(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='FREQ'
      ISUBN2='UE  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF FREQUE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NX,ND,NUMVAR
   53 FORMAT('NX,ND,NUMVAR = ',I8,I8,I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NX
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      DO60I=1,ND
      WRITE(ICOUT,61)I,D(I)
   61 FORMAT('I,D(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   60 CONTINUE
   90 CONTINUE
C
C               ********************************
C               **  STEP 1--                  **
C               **  COMPUTE DISTINCT VALUES  **
C               **  (IF NECESSARY)            **
C               ********************************
C
      IF(NUMVAR.GE.2)GOTO190
C
      ND=0
      IF(NX.LT.1)GOTO150
      DO100I=1,NX
      IF(I.EQ.1)GOTO130
      DO120J=1,ND
      IF(X(I).EQ.D(J))GOTO100
  120 CONTINUE
  130 CONTINUE
      ND=ND+1
      D(ND)=X(I)
  100 CONTINUE
      GOTO190
C
  150 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,151)
  151 FORMAT('***** ERROR IN FREQUE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,152)
  152 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,153)
  153 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,154)
  154 FORMAT('      THE DISTINCT VALUES ARE TO BE FOUND')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,155)
  155 FORMAT('      MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,156)
  156 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,157)NX
  157 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
C
  190 CONTINUE
C
C               ***************************
C               **  STEP 2--             **
C               **  COMPUTE FREQUENCIES  **
C               ***************************
C
      NY=ND
      IF(ND.LT.1)GOTO250
      DO210J=1,ND
      ISUM=0
      DO220I=1,NX
      IF(X(I).EQ.D(J))GOTO230
      GOTO220
  230 CONTINUE
      ISUM=ISUM+1
  220 CONTINUE
      Y(J)=ISUM
  210 CONTINUE
      GOTO290
C
  250 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,251)
  251 FORMAT('***** ERROR IN FREQUE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,252)
  252 FORMAT('      THE INPUT NUMBER OF DISTINCT VALUES')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,253)
  253 FORMAT('      OF THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,254)
  254 FORMAT('      FREQUENCIES ARE TO BE FOUND')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,255)
  255 FORMAT('      MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,256)
  256 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,257)ND
  257 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
C
  290 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF FREQUE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)NX,ND,NY
 9013 FORMAT('NX,ND,NY = ',3I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NX
      WRITE(ICOUT,9016)I,X(I),D(I),Y(I)
 9016 FORMAT('I,X(I),D(I),Y(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE FSTOCD (N, X, SX, RNOISE, G)
CCCCC SUBROUTINE FSTOCD (N, X, OPTFCN, SX, RNOISE, G)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C PURPOSE
C -------
C FIND CENTRAL DIFFERENCE APPROXIMATION G TO THE FIRST DERIVATIVE
C (GRADIENT) OF THE FUNCTION DEFINED BY FCN AT THE POINT X.
C
C PARAMETERS
C ----------
C N            --> DIMENSION OF PROBLEM
C X            --> POINT AT WHICH GRADIENT IS TO BE APPROXIMATED.
C FCN          --> NAME OF SUBROUTINE TO EVALUATE FUNCTION.
C SX           --> DIAGONAL SCALING MATRIX FOR X.
C RNOISE       --> RELATIVE NOISE IN FCN [F(X)].
C G           <--  CENTRAL DIFFERENCE APPROXIMATION TO GRADIENT.
C
C
      DIMENSION X(N)
      DIMENSION SX(N)
      DIMENSION G(N)
C
C FIND I TH  STEPSIZE, EVALUATE TWO NEIGHBORS IN DIRECTION OF I TH
C UNIT VECTOR, AND EVALUATE I TH  COMPONENT OF GRADIENT.
C
      THIRD = 1.0/3.0
      DO 10 I = 1, N
         STEPI = RNOISE**THIRD * MAX(ABS(X(I)), 1.0/SX(I))
         XTEMPI = X(I)
         X(I) = XTEMPI + STEPI
         CALL OPTFCN (N, X, FPLUS)
         X(I) = XTEMPI - STEPI
         CALL OPTFCN (N, X, FMINUS)
         X(I) = XTEMPI
         G(I) = (FPLUS - FMINUS)/(2.0*STEPI)
   10 CONTINUE
      RETURN
      END
      SUBROUTINE FSTOFD(NR,M,N,XPLS,FPLS,A,SX,RNOISE,FHAT,
CDPLT SUBROUTINE FSTOFD(NR,M,N,XPLS,OPTFCN,FPLS,A,SX,RNOISE,FHAT,
     +ICASE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C PURPOSE
C -------
C FIND FIRST ORDER FORWARD FINITE DIFFERENCE APPROXIMATION "A" TO THE
C FIRST DERIVATIVE OF THE FUNCTION DEFINED BY THE SUBPROGRAM "FNAME"
C EVALUATED AT THE NEW ITERATE "XPLS".
C
C
C FOR OPTIMIZATION USE THIS ROUTINE TO ESTIMATE:
C 1) THE FIRST DERIVATIVE (GRADIENT) OF THE OPTIMIZATION FUNCTION "FCN
C    ANALYTIC USER ROUTINE HAS BEEN SUPPLIED;
C 2) THE SECOND DERIVATIVE (HESSIAN) OF THE OPTIMIZATION FUNCTION
C    IF NO ANALYTIC USER ROUTINE HAS BEEN SUPPLIED FOR THE HESSIAN BUT
C    ONE HAS BEEN SUPPLIED FOR THE GRADIENT ("FCN") AND IF THE
C    OPTIMIZATION FUNCTION IS INEXPENSIVE TO EVALUATE
C
C NOTE
C ----
C _M=1 (OPTIMIZATION) ALGORITHM ESTIMATES THE GRADIENT OF THE FUNCTION
C      (FCN).   FCN(X) # F: R(N)-->R(1)
C _M=N (SYSTEMS) ALGORITHM ESTIMATES THE JACOBIAN OF THE FUNCTION
C      FCN(X) # F: R(N)-->R(N).
C _M=N (OPTIMIZATION) ALGORITHM ESTIMATES THE HESSIAN OF THE OPTIMIZATIO
C      FUNCTION, WHERE THE HESSIAN IS THE FIRST DERIVATIVE OF "FCN"
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C M            --> NUMBER OF ROWS IN A
C N            --> NUMBER OF COLUMNS IN A; DIMENSION OF PROBLEM
C XPLS(N)      --> NEW ITERATE:  X[K]
C OPTFCN       --> NAME OF SUBROUTINE TO EVALUATE FUNCTION
C FPLS(M)      --> _M=1 (OPTIMIZATION) FUNCTION VALUE AT NEW ITERATE:
C                       FCN(XPLS)
C                  _M=N (OPTIMIZATION) VALUE OF FIRST DERIVATIVE
C                       (GRADIENT) GIVEN BY USER FUNCTION FCN
C                  _M=N (SYSTEMS)  FUNCTION VALUE OF ASSOCIATED
C                       MINIMIZATION FUNCTION
C A(NR,N)     <--  FINITE DIFFERENCE APPROXIMATION (SEE NOTE).  ONLY
C                  LOWER TRIANGULAR MATRIX AND DIAGONAL ARE RETURNED
C SX(N)        --> DIAGONAL SCALING MATRIX FOR X
C RNOISE       --> RELATIVE NOISE IN FCN [F(X)]
C FHAT(M)      --> WORKSPACE
C ICASE        --> =1 OPTIMIZATION (GRADIENT)
C                  =2 SYSTEMS
C                  =3 OPTIMIZATION (HESSIAN)
C
C INTERNAL VARIABLES
C ------------------
C STEPSZ - STEPSIZE IN THE J-TH VARIABLE DIRECTION
C
      DIMENSION XPLS(N),FPLS(M)
      DIMENSION FHAT(M)
      DIMENSION SX(N)
      DIMENSION A(NR,1)
CDPLT EXTERNAL OPTFCN
C
C FIND J-TH COLUMN OF A
C EACH COLUMN IS DERIVATIVE OF F(FCN) WITH RESPECT TO XPLS(J)
C
      DO 30 J=1,N
        STEPSZ=SQRT(RNOISE)*MAX(ABS(XPLS(J)),1./SX(J))
        XTMPJ=XPLS(J)
        XPLS(J)=XTMPJ+STEPSZ
        CALL OPTFCN(N,XPLS,FHAT)
        XPLS(J)=XTMPJ
        DO 20 I=1,M
          A(I,J)=(FHAT(I)-FPLS(I))/STEPSZ
   20   CONTINUE
   30 CONTINUE
      IF(ICASE.NE.3) RETURN
C
C IF COMPUTING HESSIAN, A MUST BE SYMMETRIC
C
      IF(N.EQ.1) RETURN
      NM1=N-1
      DO 50 J=1,NM1
        JP1=J+1
        DO 40 I=JP1,M
          A(I,J)=(A(I,J)+A(J,I))/2.0
   40   CONTINUE
   50 CONTINUE
      RETURN
      END
      subroutine fts(x,n,np,trend,work)
c
c  This routine is part of the Bill Cleveland seasonal loess
c  program.
c
      integer n, np
      real x(n), trend(n), work(n)
      call ma(x,n,np,trend)
      call ma(trend,n-np+1,np,work)
      call ma(work,n-2*np+2,3,trend)
      return
      end
      subroutine fexact (nrow, ncol, table, ldtabl, expect, percnt,
     &                   emin, prt, pre,
     &                   rwrk,dwrk,iwrk)
c-----------------------------------------------------------------------
c  Name:       FEXACT
c
c  Purpose:    Computes Fisher's exact test probabilities and a hybrid
c              approximation to Fisher exact test probabilities for a
c              contingency table using the network algorithm.
c
c  Usage:      CALL FEXACT (NROW, NCOL, TABLE, LDTABL, EXPECT, PERCNT,
c                          EMIN, PRT, PRE)
c
c  Arguments:
c     NROW   - The number of rows in the table.  (Input)
c     NCOL   - The number of columns in the table.  (Input)
c     TABLE  - NROW by NCOL matrix containing the contingency table.
c              (Input)
c     LDTABL - Leading dimension of TABLE exactly as specified in the
c              dimension statement in the calling program.  (Input)
c     EXPECT - Expected value used in the hybrid algorithm for
c              deciding when to use asymptotic theory probabilities.
c              (Input)
c              If EXPECT .LE. 0.0 then asymptotic theory probabilities
c              are not used and Fisher exact test probabilities are
c              computed.  Otherwise, if PERCNT or more of the cells in
c              the remaining table have estimated expected values of
c              EXPECT or more, with no remaining cell having expected
c              value less than EMIN, then asymptotic chi-squared
c              probabilities are used.  See the algorithm section of the
c              manual document for details.  Use EXPECT = 5.0 to obtain
c              the 'Cochran' condition.
c     PERCNT - Percentage of remaining cells that must have estimated
c              expected  values greater than EXPECT before asymptotic
c              probabilities can be used.  (Input)
c              See argument EXPECT for details.  Use PERCNT = 80.0 to
c              obtain the 'Cochran' condition.
c     EMIN   - Minimum cell estimated expected value allowed for
c              asymptotic chi-squared probabilities to be used.  (Input)
c              See argument EXPECT for details.  Use EMIN = 1.0 to
c              obtain the 'Cochran' condition.
c     PRT    - Probability of the observed table for fixed marginal
c              totals.  (Output)
c     PRE    - Table p-value.  (Output)
c              PRE is the probability of a more extreme table, where
c              'extreme' is in a probabilistic sense.
c              If EXPECT .LT. 0 then the Fisher exact probability
c              is returned.  Otherwise, an approximation to the
c              Fisher exact probability is computed based upon
c              asymptotic chi-squared probabilities for ``large''
c              table expected values.  The user defines ``large''
c              through the arguments EXPECT, PERCNT, and EMIN.
c
c  Remarks:
c  1. For many problems one megabyte or more of workspace can be 
c     required.  If the environment supports it, the user should begin 
c     by increasing the workspace used to 200,000 units. 
c
c  2. In FEXACT, LDSTP = 30*LDKEY.  The proportion of table space used 
c     by STP may be changed by changing the line MULT = 30 below to 
c     another value.
c
c  3. FEXACT may be converted to single precision by setting IREAL = 3,
c     and converting all DOUBLE PRECISION specifications (except the 
c     specifications for RWRK, IWRK, and DWRK) to REAL.  This will 
c     require changing the names and specifications of the intrinsic
c     functions ALOG, AMAX1, AMIN1, EXP, and REAL.  In addition, the
c     machine specific constants will need to be changed, and the name
c     DWRK will need to be changed to RWRK in the call to F2XACT.
c
c  4. Machine specific constants are specified and documented in F2XACT.
c     A missing value code is specified in both FEXACT and F2XACT.
c
c  5. Although not a restriction, is is not generally practical to call
c     this routine with large tables which are not sparse and in
c     which the 'hybrid' algorithm has little effect.  For example,
c     although it is feasible to compute exact probabilities for the
c     table
c            1 8 5 4 4 2 2
c            5 3 3 4 3 1 0
c           10 1 4 0 0 0 0,
c     computing exact probabilities for a similar table which has been
c     enlarged by the addition of an extra row (or column) may not be
c     feasible.
c-----------------------------------------------------------------------
c                                  SPECIFICATIONS FOR ARGUMENTS
      integer    nrow, ncol, ldtabl
      double precision expect, percnt, emin, prt, pre, table(ldtabl,*)
c                                  SPECIFICATIONS FOR LOCAL VARIABLES
      integer    i, i1, i10, i2, i3, i3a, i3b, i3c, i4, i5, i6, i7,
     &           i8, i9, i9a, iiwk, ireal, irwk, iwkmax, iwkpt,
     &           j, k, kk, ldkey, ldstp, mult, nco, nro,
     &           ntot, numb
c                                  SPECIFICATIONS FOR INTRINSICS
      intrinsic  max0
      integer    max0
c                                  SPECIFICATIONS FOR SUBROUTINES
ccccc external   prterr, f2xact
      external   f2xact
c                                  SPECIFICATIONS FOR FUNCTIONS
      external   iwork
      integer    iwork
c***********************************************************************
c                                  To increase workspace, increase the
c                                  size of of rwrk and set the value of 
c                                  IWKMAX to the new dimension
c
c                                  When changing precision, the 
c                                  following declarations should not be
c                                  changed.
c***********************************************************************
ccccc real       rwrk(200000)
ccccc double precision dwrk(100000)
ccccc integer    iwrk(100000)
ccccc equivalence (rwrk(1), iwrk(1)), (rwrk(1),dwrk(1))
      real rwrk(*)
      double precision dwrk(*)
      integer iwrk(*)
c                                  Set workspace size
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      iwkmax = 200000
c***********************************************************************
c                                  To increase the length of the table
c                                  of paste path lengths relative to the
c                                  length of the hash table,  increase
c                                  MULT 
c***********************************************************************
      mult   = 30
c***********************************************************************
c                                  Set IREAL = 4 for DOUBLE PRECISION
c                                  Set IREAL = 3 for SINGLE PRECISION
c***********************************************************************
      ireal  = 4
c***********************************************************************
c                                  AMISS is a missing value indicator
c                                  which is returned when the
c                                  probability is not defined.
c***********************************************************************
      amiss = -12345.0d0
c
      iwkpt  = 1
c
      if (nrow .gt. ldtabl) then
CCCCC    call prterr (1, 'NROW must be less than or equal to '//
CCCCC&               'LDTABL.')
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** ERROR FROM FEXACT.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)
 9013 FORMAT('      NROW must be less than or equal to LDTABL.')
      CALL DPWRST('XXX','BUG ')
      end if
      ntot = 0
      do 20  i=1, nrow
         do 10  j=1, ncol
            if (table(i,j) .lt. 0) then
CCCCC          call prterr (2, 'All elements of TABLE must '//
CCCCC&                     'be positive.')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9113)
 9113 FORMAT('      All elements of TABLE must be positive.')
      CALL DPWRST('XXX','BUG ')
            end if
            ntot = ntot + table(i,j)
   10    continue
   20 continue
      if (ntot .eq. 0) then
ccccc    call prterr (3, 'All elements of TABLE are zero.  '//
ccccc&               'PRT and PRE are set to missing values '//
ccccc&               '(NaN, not a number).')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9213)
 9213 FORMAT('      All elements of TABLE are zero.  PRT and PRE are')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9215)
 9215 FORMAT('      set to missing values (NaN, not a number).')
      CALL DPWRST('XXX','BUG ')
         prt = amiss
         pre = amiss
         go to 9000
      end if
c
      nco = max0(nrow,ncol)
      nro = nrow + ncol - nco
      k   = nrow + ncol + 1
      kk  = k*max0(nrow,ncol)
c
      i1   = iwork(iwkmax,iwkpt,ntot+1,ireal)
      i2   = iwork(iwkmax,iwkpt,nco,2)
      i3   = iwork(iwkmax,iwkpt,nco,2)
      i3a  = iwork(iwkmax,iwkpt,nco,2)
      i3b  = iwork(iwkmax,iwkpt,nro,2)
      i3c  = iwork(iwkmax,iwkpt,nro,2)
      iiwk = iwork(iwkmax,iwkpt,max0(5*k+2*kk,800+7*max0(nrow,ncol)),2)
      irwk = iwork(iwkmax,iwkpt,max0(400+max0(nrow,ncol)+1,k),ireal)
c                                  Double precision
      if (ireal .eq. 4) then
         numb  = 18 + 10*mult
         ldkey = (iwkmax-iwkpt+1)/numb
      else
c                                  Real workspace
         numb  = 12 + 8*mult
         ldkey = (iwkmax-iwkpt+1)/numb
      end if
c
      ldstp = mult*ldkey
      i4    = iwork(iwkmax,iwkpt,2*ldkey,2)
      i5    = iwork(iwkmax,iwkpt,2*ldkey,2)
      i6    = iwork(iwkmax,iwkpt,2*ldstp,ireal)
      i7    = iwork(iwkmax,iwkpt,6*ldstp,2)
      i8    = iwork(iwkmax,iwkpt,2*ldkey,ireal)
      i9    = iwork(iwkmax,iwkpt,2*ldkey,ireal)
      i9a   = iwork(iwkmax,iwkpt,2*ldkey,ireal)
      i10   = iwork(iwkmax,iwkpt,2*ldkey,2)
c***********************************************************************
c                                  To convert to double precision,
c                                  change RWRK to WWRK in the next CALL
c***********************************************************************
c
      call f2xact (nrow, ncol, table, ldtabl, expect, percnt, emin,
     &             prt, pre, dwrk(i1), iwrk(i2), iwrk(i3), iwrk(i3a),
     &             iwrk(i3b), iwrk(i3c), iwrk(i4), ldkey, iwrk(i5),
     &             dwrk(i6), ldstp, iwrk(i7), dwrk(i8), dwrk(i9),
     &             dwrk(i9a), iwrk(i10), iwrk(iiwk), dwrk(irwk))
c
 9000 return
      end
      subroutine f2xact (nrow, ncol, table, ldtabl, expect, percnt,
     &                   emin, prt, pre, fact, ico, iro, kyy, idif,
     &                   irn, key, ldkey, ipoin, stp, ldstp, ifrq,
     &                   dlp, dsp, tm, key2, iwk, rwk)
c-----------------------------------------------------------------------
c  Name:       F2XACT
c
c  Purpose:    Computes Fisher's exact test for a contingency table,
c              routine with workspace variables specified.
c
c  Usage:      CALL F2XACT (NROW, NCOL, TABLE, LDTABL, EXPECT, PERCNT,
c                          EMIN, PRT, PRE, FACT, ICO, IRO, KYY, IDIF,
c                          IRN, KEY, LDKEY, IPOIN, STP, LDSTP, IFRQ,
c                          DLP, DSP, TM, KEY2, IWK, RWK)
c-----------------------------------------------------------------------
c                                  SPECIFICATIONS FOR ARGUMENTS
      integer    nrow, ncol, ldtabl, ldkey, ldstp, ico(*), iro(*),
     &           kyy(*), idif(*), irn(*), key(*), ipoin(*), ifrq(*),
     &           key2(*), iwk(*)
      double precision expect, percnt, emin, prt, pre, table(ldtabl,*),
     &           fact(0:*), stp(*), dlp(*), dsp(*), tm(*), rwk(*)
c                                  SPECIFICATIONS FOR LOCAL VARIABLES
      integer    i, i31, i310, i311, i32, i33, i34, i35, i36, i37,
     &           i38, i39, i41, i42, i43, i44, i45, i46, i47, i48,
     &           iflag, ifreq, ii, ikkey, ikstp, ikstp2, ipn, ipo,
     &           itmp, itop, itp, j, jkey, jstp, jstp2, jstp3, jstp4,
     &           k, k1, kb, kd, kmax, ks, kval, last, n, ncell, nco,
     &           nrb, nro, nro2, ntot, ifault, imax
      double precision dd, ddf, df, drn, dro, dspt, emn, obs, obs2, 
     &           obs3, pastp, pv, tmp, tol
      logical    chisq, ipsh
c                                  SPECIFICATIONS FOR INTRINSICS
      intrinsic  dlog, dmax1, dmin1, dexp, max0, min0, mod, nint, dble
      integer    max0, min0, mod, nint
      double precision dlog, dmax1, dmin1, dexp, dble
c                                  SPECIFICATIONS FOR SUBROUTINES
ccccc external   prterr, f3xact, f4xact, f5xact, f6xact, f7xact, isort
      external   f3xact, f4xact, f5xact, f6xact, f7xact, isort
c                                  SPECIFICATIONS FOR FUNCTIONS
      external   f9xact, gammds
      double precision f9xact, gammds
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
c***********************************************************************
c                                  IMAX is the largest representable
c                                  integer on the machine
c***********************************************************************
      data imax/2147483647/
c***********************************************************************
c                                  AMISS is a missing value indicator
c                                  which is returned when the
c                                  probability is not defined.
c***********************************************************************
      data amiss/-12345.0d0/
c***********************************************************************
c                                  TOL is chosen as the square root of
c                                  the smallest relative spacing
c***********************************************************************
      data tol/3.45254d-07/
c***********************************************************************
c                                  EMX is a large positive value used 
c                                  in comparing expected values
c***********************************************************************
      data emx/1.0d30/
c                                  Initialize KEY array
      do 10  i=1, 2*ldkey
         key(i)  = -9999
         key2(i) = -9999
   10 continue
c                                  Initialize parameters
      pre  = 0.0
      itop = 0
      if (expect .gt. 0.0d0) then
         emn = emin
      else
         emn = emx
      end if
c                                  Initialize pointers for workspace
      k = max0(nrow,ncol)
c                                  f3xact
      i31  = 1
      i32  = i31 + k
      i33  = i32 + k
      i34  = i33 + k
      i35  = i34 + k
      i36  = i35 + k
      i37  = i36 + k
      i38  = i37 + k
      i39  = i38 + 400
      i310 = 1
      i311 = 401
c                                  f4xact
      k   = nrow + ncol + 1
      i41 = 1
      i42 = i41 + k
      i43 = i42 + k
      i44 = i43 + k
      i45 = i44 + k
      i46 = i45 + k
      i47 = i46 + k*max0(nrow,ncol)
      i48 = 1
c                                  Check table dimensions
      if (nrow .gt. ldtabl) then
CCCCC    call prterr (1, 'NROW must be less than or equal to '//
CCCCC&               'LDTABL.')
         WRITE(ICOUT,999)
  999    FORMAT(1X)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9011)
 9011    FORMAT('***** ERROR IN F2XACT--')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9013)
 9013    FORMAT('      NROW must be less than or equal to LDTABL.')
         CALL DPWRST('XXX','BUG ')
      end if
      if (ncol .le. 1) then
ccccc    call prterr (4, 'NCOL must be greater than 1.0.')
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9011)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9113)
 9113    FORMAT('      NCOL must be greater than 1.0.')
         CALL DPWRST('XXX','BUG ')
      end if
c                                  Compute row marginals and total
      ntot = 0
      do 30  i=1, nrow
         iro(i) = 0
         do 20  j=1, ncol
            if (table(i,j) .lt. -0.0001d0) then
CCCCC          call prterr (2, 'All elements of TABLE must be '//
CCCCC&                     'positive.')
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9011)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9123)
 9123    FORMAT('       All elements of TABLE must be positive.')
         CALL DPWRST('XXX','BUG ')
            end if
            iro(i) = iro(i) + nint(table(i,j))
            ntot   = ntot + nint(table(i,j))
   20    continue
   30 continue
c
      if (ntot .eq. 0) then
CCCCC    call prterr (3, 'All elements of TABLE are zero.  '//
CCCCC&               'PRT and PRE are set to missing values '//
CCCCC&               '(NaN, not a number).')
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9011)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9133)
 9133    FORMAT('       All elements of TABLE are zero.  PRT and PRE')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9135)
 9135    FORMAT('       are set to missing values (NaN, not a ',
     &          'number).')
         CALL DPWRST('XXX','BUG ')
         prt = amiss
         pre = amiss
         go to 9000
      end if
c                                  Column marginals
      do 50  i=1, ncol
         ico(i) = 0
         do 40  j=1, nrow
            ico(i) = ico(i) + nint(table(j,i))
   40    continue
   50 continue
c                                  sort
      call isort (nrow, iro)
      call isort (ncol, ico)
c                                  Determine row and column marginals
c
      if (nrow .gt. ncol) then
         nro = ncol
         nco = nrow
c                                  Interchange row and column marginals
         do 60  i=1, nrow
            itmp = iro(i)
            if (i .le. ncol) iro(i) = ico(i)
            ico(i) = itmp
   60    continue
      else
         nro = nrow
         nco = ncol
      end if
c
c                                  Get multiplers for stack
      kyy(1) = 1
      do 70  i=2, nro
c                                  Hash table multipliers
         if (iro(i-1)+1 .le. imax/kyy(i-1)) then
            kyy(i) = kyy(i-1)*(iro(i-1)+1)
            j      = j/kyy(i-1)
         else
CCCCC       call prterr (5, 'The hash table key cannot be computed'//
CCCCC&                  ' because the largest key is larger than the'//
CCCCC&                  ' largest representable integer.  The '//
CCCCC&                  'algorithm cannot proceed.')
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9011)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9143)
 9143    FORMAT('       The hash table key cannot be computed because')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9145)
 9145    FORMAT('       the largest key is larger than the largest')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9147)
 9147    FORMAT('       representable integer.  The algorithm cannot',
     &          ' proceed.')
         CALL DPWRST('XXX','BUG ')
         end if
   70 continue
c                                  Maximum product
      if (iro(nro-1)+1 .le. imax/kyy(nro-1)) then
         kmax = (iro(nro)+1)*kyy(nro-1)
      else
ccccc    call prterr (5, 'The hash table key cannot be computed'//
ccccc&               ' because the largest key is larger than the'//
ccccc&               ' largest representable integer.  The '//
ccccc&               'algorithm cannot proceed.')
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9011)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9143)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9145)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9147)
         CALL DPWRST('XXX','BUG ')
         go to 9000
      end if
c                                  Compute log factorials
      fact(0) = 0.0d0
      fact(1) = 0.0d0
      fact(2) = dlog(2.0d0)
      do 80  i=3, ntot, 2
         fact(i) = fact(i-1) + dlog(dble(i))
         j       = i + 1
         if (j .le. ntot) fact(j) = fact(i) + fact(2) + fact(j/2) -
     &       fact(j/2-1)
   80 continue
c                                  Compute observed path length: OBS
      obs  = tol
      ntot = 0
      do 100  j=1, nco
         dd = 0.0
         do 90  i=1, nro
            if (nrow .le. ncol) then
               dd   = dd + fact(nint(table(i,j)))
               ntot = ntot + nint(table(i,j))
            else
               dd   = dd + fact(nint(table(j,i)))
               ntot = ntot + nint(table(j,i))
            end if
   90    continue
         obs = obs + fact(ico(j)) - dd
  100 continue
c                                  Denominator of observed table: DRO
      dro = f9xact(nro,ntot,iro,fact)
      prt = dexp(obs-dro)
c                                  Initialize pointers
      k        = nco
      last     = ldkey + 1
      jkey     = ldkey + 1
      jstp     = ldstp + 1
      jstp2    = 3*ldstp + 1
      jstp3    = 4*ldstp + 1
      jstp4    = 5*ldstp + 1
      ikkey    = 0
      ikstp    = 0
      ikstp2   = 2*ldstp
      ipo      = 1
      ipoin(1) = 1
      stp(1)   = 0.0
      ifrq(1)  = 1
      ifrq(ikstp2+1) = -1
c
  110 kb = nco - k + 1
      ks   = 0
      n    = ico(kb)
      kd   = nro + 1
      kmax = nro
c                                  IDIF is the difference in going to th
c                                  daughter
      do 120  i=1, nro
         idif(i) = 0
  120 continue
c                                  Generate the first daughter
  130 kd = kd - 1
      ntot     = min0(n,iro(kd))
      idif(kd) = ntot
      if (idif(kmax) .eq. 0) kmax = kmax - 1
      n = n - ntot
      if (n.gt.0 .and. kd.ne.1) go to 130
      if (n .ne. 0) go to 310
c
      k1   = k - 1
      n    = ico(kb)
      ntot = 0
      do 140  i=kb + 1, nco
         ntot = ntot + ico(i)
  140 continue
c                                  Arc to daughter length=ICO(KB)
  150 do 160  i=1, nro
         irn(i) = iro(i) - idif(i)
  160 continue
c                                  Sort irn
      if (k1 .gt. 1) then
         if (nro .eq. 2) then
            if (irn(1) .gt. irn(2)) then
               ii     = irn(1)
               irn(1) = irn(2)
               irn(2) = ii
            end if
         else if (nro .eq. 3) then
            ii = irn(1)
            if (ii .gt. irn(3)) then
               if (ii .gt. irn(2)) then
                  if (irn(2) .gt. irn(3)) then
                     irn(1) = irn(3)
                     irn(3) = ii
                  else
                     irn(1) = irn(2)
                     irn(2) = irn(3)
                     irn(3) = ii
                  end if
               else
                  irn(1) = irn(3)
                  irn(3) = irn(2)
                  irn(2) = ii
               end if
            else if (ii .gt. irn(2)) then
               irn(1) = irn(2)
               irn(2) = ii
            else if (irn(2) .gt. irn(3)) then
               ii     = irn(2)
               irn(2) = irn(3)
               irn(3) = ii
            end if
         else
            do 180  j=2, nro
               i  = j - 1
               ii = irn(j)
  170          if (ii .lt. irn(i)) then
                  irn(i+1) = irn(i)
                  i        = i - 1
                  if (i .gt. 0) go to 170
               end if
               irn(i+1) = ii
  180       continue
         end if
c                                  Adjust start for zero
         do 190  i=1, nro
            if (irn(i) .ne. 0) go to 200
  190    continue
  200    nrb = i
         nro2 = nro - i + 1
      else
         nrb  = 1
         nro2 = nro
      end if
c                                  Some table values
      ddf = f9xact(nro,n,idif,fact)
      drn = f9xact(nro2,ntot,irn(nrb),fact) - dro + ddf
c                                  Get hash value
      if (k1 .gt. 1) then
         kval = irn(1) + irn(2)*kyy(2)
         do 210  i=3, nro
            kval = kval + irn(i)*kyy(i)
  210    continue
c                                  Get hash table entry
         i = mod(kval,2*ldkey) + 1
c                                  Search for unused location
         do 220  itp=i, 2*ldkey
            ii = key2(itp)
            if (ii .eq. kval) then
               go to 240
            else if (ii .lt. 0) then
               key2(itp) = kval
               dlp(itp)  = 1.0d0
               dsp(itp)  = 1.0d0
               go to 240
            end if
  220    continue
c
         do 230  itp=1, i - 1
            ii = key2(itp)
            if (ii .eq. kval) then
               go to 240
            else if (ii .lt. 0) then
               key2(itp) = kval
               dlp(itp)  = 1.0
               go to 240
            end if
  230    continue
c
ccccc    call prterr (6, 'LDKEY is too small.  It is not possible to '//
ccccc&               'give thevalue of LDKEY required, but you could '//
ccccc&               'try doubling LDKEY (and possibly LDSTP).')
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9011)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9153)
 9153    FORMAT('        LDKEY is too small.  It is not possible to ')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9155)
 9155    FORMAT('        give the value of LDKEY required, but you')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9157)
 9157    FORMAT('        could try doubling LDKEY (and possibly ',
     &          'LDSTP).')
         CALL DPWRST('XXX','BUG ')
      end if
c
  240 ipsh = .true.
c                                  Recover pastp
      ipn   = ipoin(ipo+ikkey)
      pastp = stp(ipn+ikstp)
      ifreq = ifrq(ipn+ikstp)
c                                  Compute shortest and longest path
      if (k1 .gt. 1) then
         obs2 = obs - fact(ico(kb+1)) - fact(ico(kb+2)) - ddf
         do 250  i=3, k1
            obs2 = obs2 - fact(ico(kb+i))
  250    continue
c
         if (dlp(itp) .gt. 0.0d0) then
            dspt = obs - obs2 - ddf
c                                  Compute longest path
            dlp(itp) = 0.0d0
            call f3xact (nro2, irn(nrb), k1, ico(kb+1), dlp(itp),
     &                   ntot, fact, iwk(i31), iwk(i32), iwk(i33),
     &                   iwk(i34), iwk(i35), iwk(i36), iwk(i37),
     &                   iwk(i38), iwk(i39), rwk(i310), rwk(i311), tol)
            dlp(itp) = dmin1(0.0d0,dlp(itp))
c                                  Compute shortest path
            dsp(itp) = dspt
            call f4xact (nro2, irn(nrb), k1, ico(kb+1), dsp(itp),
     &                   fact, iwk(i47), iwk(i41), iwk(i42), iwk(i43),
     &                   iwk(i44), iwk(i45), iwk(i46), rwk(i48), tol)
            dsp(itp) = dmin1(0.0d0,dsp(itp)-dspt)
c                                  Use chi-squared approximation?
            if (dble(irn(nrb)*ico(kb+1))/dble(ntot) .gt. emn) then
               ncell = 0.0
               do 270  i=1, nro2
                  do 260  j=1, k1
                     if (irn(nrb+i-1)*ico(kb+j) .ge. ntot*expect) then
                        ncell = ncell + 1
                     end if
  260             continue
  270          continue
               if (ncell*100 .ge. k1*nro2*percnt) then
                  tmp = 0.0
                  do 280  i=1, nro2
                     tmp = tmp + fact(irn(nrb+i-1)) -
     &                     fact(irn(nrb+i-1)-1)
  280             continue
                  tmp = tmp*(k1-1)
                  do 290  j=1, k1
                     tmp = tmp + (nro2-1)*(fact(ico(kb+j))-fact(ico(kb+
     &                     j)-1))
  290             continue
                  df      = (nro2-1)*(k1-1)
                  tmp     = tmp + df*1.83787706640934548356065947281d0
                  tmp     = tmp - (nro2*k1-1)*(fact(ntot)-fact(ntot-1))
                  tm(itp) = -2.0d0*(obs-dro) - tmp
               else
c                                  tm(itp) set to a flag value
                  tm(itp) = -9876.0d0
               end if
            else
               tm(itp) = -9876.0d0
            end if
         end if
         obs3 = obs2 - dlp(itp)
         obs2 = obs2 - dsp(itp)
         if (tm(itp) .eq. -9876.0d0) then
            chisq = .false.
         else
            chisq = .true.
            tmp   = tm(itp)
         end if
      else
         obs2 = obs - drn - dro
         obs3 = obs2
      end if
c                                  Process node with new PASTP
  300 if (pastp .le. obs3) then
c                                  Update pre
         pre = pre + dble(ifreq)*dexp(pastp+drn)
c
      else if (pastp .lt. obs2) then
         if (chisq) then
            df  = (nro2-1)*(k1-1)
            pv  = 1.0 - gammds(dmax1(0.0d0,tmp+2.0d0*(pastp+drn))/
     &            2.0d0,df/2.0d0,ifault)
            pre = pre + dble(ifreq)*dexp(pastp+drn)*pv
         else
c                                  Put daughter on queue
            call f5xact (pastp+ddf, tol, kval, key(jkey), ldkey,
     &                   ipoin(jkey), stp(jstp), ldstp, ifrq(jstp),
     &                   ifrq(jstp2), ifrq(jstp3), ifrq(jstp4), ifreq,
     &                   itop, ipsh)
            ipsh = .false.
         end if
      end if
c                                  Get next PASTP on chain
      ipn = ifrq(ipn+ikstp2)
      if (ipn .gt. 0) then
         pastp = stp(ipn+ikstp)
         ifreq = ifrq(ipn+ikstp)
         go to 300
      end if
c                                  Generate a new daughter node
      call f7xact (kmax, iro, idif, kd, ks, iflag)
      if (iflag .ne. 1) go to 150
c                                  Go get a new mother from stage K
  310 iflag = 1
      call f6xact (nro, iro, iflag, kyy, key(ikkey+1), ldkey, last,
     &             ipo)
c                                  Update pointers
      if (iflag .eq. 3) then
         k      = k - 1
         itop   = 0
         ikkey  = jkey - 1
         ikstp  = jstp - 1
         ikstp2 = jstp2 - 1
         jkey   = ldkey - jkey + 2
         jstp   = ldstp - jstp + 2
         jstp2  = 2*ldstp + jstp
         do 320  i=1, 2*ldkey
            key2(i) = -9999
  320    continue
         if (k .ge. 2) go to 310
      else
         go to 110
      end if
c
 9000 return
      end
      subroutine f3xact (nrow, irow, ncol, icol, dlp, mm, fact, ico,
     &                   iro, it, lb, nr, nt, nu, itc, ist, stv, alen,
     &                   tol)
c-----------------------------------------------------------------------
c  Name:       F3XACT
c
c  Purpose:    Computes the shortest path length for a given table.
c
c  Usage:      CALL F3XACT (NROW, IROW, NCOL, ICOL, DLP, MM, FACT, ICO,
c                          IRO, IT, LB, NR, NT, NU, ITC, IST, STV, ALEN,
c                          TOL)
c
c  Arguments:
c     NROW   - The number of rows in the table.  (Input)
c     IROW   - Vector of length NROW containing the row sums for the
c              table.  (Input)
c     NCOL   - The number of columns in the table.  (Input)
c     ICOL   - Vector of length K containing the column sums for the
c              table.  (Input)
c     DLP    - The longest path for the table.  (Output)
c     MM     - The total count in the table.  (Output)
c     FACT   - Vector containing the logarithms of factorials.  (Input)
c     ICO    - Work vector of length MAX(NROW,NCOL).
c     IRO    - Work vector of length MAX(NROW,NCOL).
c     IT     - Work vector of length MAX(NROW,NCOL).
c     LB     - Work vector of length MAX(NROW,NCOL).
c     NR     - Work vector of length MAX(NROW,NCOL).
c     NT     - Work vector of length MAX(NROW,NCOL).
c     NU     - Work vector of length MAX(NROW,NCOL).
c     ITC    - Work vector of length 400.
c     IST    - Work vector of length 400.
c     STV    - Work vector of length 400.
c     ALEN   - Work vector of length MAX(NROW,NCOL).
c     TOL    - Tolerance.  (Input)
c-----------------------------------------------------------------------
c                                  SPECIFICATIONS FOR ARGUMENTS
      integer    nrow, ncol, mm, irow(*), icol(*), ico(*), iro(*),
     &           it(*), lb(*), nr(*), nt(*), nu(*), itc(*), ist(*)
      double precision dlp, tol, fact(0:*), stv(*), alen(0:*)
c                                  SPECIFICATIONS FOR LOCAL VARIABLES
      integer    i, ic1, ic2, ii, ipn, irl, itp, k, key, ks, kyy, lev,
     &           n11, n12, nc1, nc1s, nco, nct, nn, nn1, nr1, nro, nrt
      double precision v, val, vmn
      logical    xmin
c                                  SPECIFICATIONS FOR SAVE VARIABLES
      integer    ldst, nitc, nst
      save       ldst, nitc, nst
c                                  SPECIFICATIONS FOR INTRINSICS
      intrinsic  dmin1, int, mod, dble
      integer    int, mod
      double precision dmin1, dble
c                                  SPECIFICATIONS FOR SUBROUTINES
ccccc external   prterr, f10act, isort
      external   f10act, isort
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
c***********************************************************************
c
      data ldst/200/, nst/0/, nitc/0/
c
      do 10  i=0, ncol
         alen(i) = 0.0
   10 continue
      do 20  i=1, 400
         ist(i) = -1
   20 continue
c                                  nrow is 1
      if (nrow .le. 1) then
         if (nrow .gt. 0) then
            dlp = dlp - fact(icol(1))
            do 30  i=2, ncol
               dlp = dlp - fact(icol(i))
   30       continue
         end if
         go to 9000
      end if
c                                  ncol is 1
      if (ncol .le. 1) then
         if (ncol .gt. 0) then
            dlp = dlp - fact(irow(1)) - fact(irow(2))
            do 40  i=3, nrow
               dlp = dlp - fact(irow(i))
   40       continue
         end if
         go to 9000
      end if
c                                  2 by 2 table
      if (nrow*ncol .eq. 4) then
         n11 = (irow(1)+1)*(icol(1)+1)/(mm+2)
         n12 = irow(1) - n11
         dlp = dlp - fact(n11) - fact(n12) - fact(icol(1)-n11) -
     &         fact(icol(2)-n12)
         go to 9000
      end if
c                                  Test for optimal table
      val  = 0.0
      xmin = .false.
      if (irow(nrow) .le. irow(1)+ncol) then
         call f10act (nrow, irow, ncol, icol, val, xmin, fact, lb, nu,
     &                nr)
      end if
      if (.not.xmin) then
         if (icol(ncol) .le. icol(1)+nrow) then
            call f10act (ncol, icol, nrow, irow, val, xmin, fact, lb,
     &                   nu, nr)
         end if
      end if
c
      if (xmin) then
         dlp = dlp - val
         go to 9000
      end if
c                                  Setup for dynamic programming
      nn = mm
c                                  Minimize ncol
      if (nrow .ge. ncol) then
         nro = nrow
         nco = ncol
c
         do 50  i=1, nrow
            iro(i) = irow(i)
   50    continue
c
         ico(1) = icol(1)
         nt(1)  = nn - ico(1)
         do 60  i=2, ncol
            ico(i) = icol(i)
            nt(i)  = nt(i-1) - ico(i)
   60    continue
      else
         nro = ncol
         nco = nrow
c
         ico(1) = irow(1)
         nt(1)  = nn - ico(1)
         do 70  i=2, nrow
            ico(i) = irow(i)
            nt(i)  = nt(i-1) - ico(i)
   70    continue
c
         do 80  i=1, ncol
            iro(i) = icol(i)
   80    continue
      end if
c                                  Initialize pointers
      vmn  = 1.0d10
      nc1s = nco - 1
      irl  = 1
      ks   = 0
      k    = ldst
      kyy  = ico(nco) + 1
      go to 100
c                                  Test for optimality
   90 xmin = .false.
      if (iro(nro) .le. iro(irl)+nco) then
         call f10act (nro, iro(irl), nco, ico, val, xmin, fact, lb,
     &                nu, nr)
      end if
      if (.not.xmin) then
         if (ico(nco) .le. ico(1)+nro) then
            call f10act (nco, ico, nro, iro(irl), val, xmin, fact, lb,
     &                   nu, nr)
         end if
      end if
c
      if (xmin) then
         if (val .lt. vmn) vmn = val
         go to 200
      end if
c                                  Setup to generate new node
  100 lev = 1
      nr1   = nro - 1
      nrt   = iro(irl)
      nct   = ico(1)
      lb(1) = int(dble((nrt+1)*(nct+1))/dble(nn+nr1*nc1s+1)-tol) - 1
      nu(1) = int(dble((nrt+nc1s)*(nct+nr1))/dble(nn+nr1+nc1s)) -
     &        lb(1) + 1
      nr(1) = nrt - lb(1)
c                                  Generate a node
  110 nu(lev) = nu(lev) - 1
      if (nu(lev) .eq. 0) then
         if (lev .eq. 1) go to 200
         lev = lev - 1
         go to 110
      end if
      lb(lev) = lb(lev) + 1
      nr(lev) = nr(lev) - 1
  120 alen(lev) = alen(lev-1) + fact(lb(lev))
      if (lev .lt. nc1s) then
         nn1     = nt(lev)
         nrt     = nr(lev)
         lev     = lev + 1
         nc1     = nco - lev
         nct     = ico(lev)
         lb(lev) = dble((nrt+1)*(nct+1))/dble(nn1+nr1*nc1+1) - tol
         nu(lev) = dble((nrt+nc1)*(nct+nr1))/dble(nn1+nr1+nc1) -
     &             lb(lev) + 1
         nr(lev) = nrt - lb(lev)
         go to 120
      end if
      alen(nco) = alen(lev) + fact(nr(lev))
      lb(nco)   = nr(lev)
c
      v = val + alen(nco)
      if (nro .eq. 2) then
c                                  Only 1 row left
         v = v + fact(ico(1)-lb(1)) + fact(ico(2)-lb(2))
         do 130  i=3, nco
            v = v + fact(ico(i)-lb(i))
  130    continue
         if (v .lt. vmn) vmn = v
      else if (nro.eq.3 .and. nco.eq.2) then
c                                  3 rows and 2 columns
         nn1 = nn - iro(irl) + 2
         ic1 = ico(1) - lb(1)
         ic2 = ico(2) - lb(2)
         n11 = (iro(irl+1)+1)*(ic1+1)/nn1
         n12 = iro(irl+1) - n11
         v   = v + fact(n11) + fact(n12) + fact(ic1-n11) +
     &         fact(ic2-n12)
         if (v .lt. vmn) vmn = v
      else
c                                  Column marginals are new node
         do 140  i=1, nco
            it(i) = ico(i) - lb(i)
  140    continue
c                                  Sort column marginals
         if (nco .eq. 2) then
            if (it(1) .gt. it(2)) then
               ii    = it(1)
               it(1) = it(2)
               it(2) = ii
            end if
         else if (nco .eq. 3) then
            ii = it(1)
            if (ii .gt. it(3)) then
               if (ii .gt. it(2)) then
                  if (it(2) .gt. it(3)) then
                     it(1) = it(3)
                     it(3) = ii
                  else
                     it(1) = it(2)
                     it(2) = it(3)
                     it(3) = ii
                  end if
               else
                  it(1) = it(3)
                  it(3) = it(2)
                  it(2) = ii
               end if
            else if (ii .gt. it(2)) then
               it(1) = it(2)
               it(2) = ii
            else if (it(2) .gt. it(3)) then
               ii    = it(2)
               it(2) = it(3)
               it(3) = ii
            end if
         else
            call isort (nco, it)
         end if
c                                  Compute hash value
         key = it(1)*kyy + it(2)
         do 150  i=3, nco
            key = it(i) + key*kyy
  150    continue
c                                  Table index
         ipn = mod(key,ldst) + 1
c                                  Find empty position
         ii = ks + ipn
         do 160  itp=ipn, ldst
            if (ist(ii) .lt. 0) then
               go to 180
            else if (ist(ii) .eq. key) then
               go to 190
            end if
            ii = ii + 1
  160    continue
c
         ii = ks + 1
         do 170  itp=1, ipn - 1
            if (ist(ii) .lt. 0) then
               go to 180
            else if (ist(ii) .eq. key) then
               go to 190
            end if
            ii = ii + 1
  170    continue
c
CCCCC    call prterr (30, 'Stack length exceeded in f3xact.'//
CCCCC&               '  This problem should not occur.')
         WRITE(ICOUT,999)
  999    FORMAT(1X)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9011)
 9011    FORMAT('***** ERROR IN R3XACT--')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,9013)
 9013    FORMAT('      Stack length exceeded in f3xact.  This ',
     1          'problem should not occur.')
         CALL DPWRST('XXX','BUG ')
c                                  Push onto stack
  180    ist(ii) = key
         stv(ii) = v
         nst     = nst + 1
         ii      = nst + ks
         itc(ii) = itp
         go to 110
c                                  Marginals already on stack
  190    stv(ii) = dmin1(v,stv(ii))
      end if
      go to 110
c                                  Pop item from stack
  200 if (nitc .gt. 0) then
c                                  Stack index
         itp      = itc(nitc+k) + k
         nitc     = nitc - 1
         val      = stv(itp)
         key      = ist(itp)
         ist(itp) = -1
c                                  Compute marginals
         do 210  i=nco, 2, -1
            ico(i) = mod(key,kyy)
            key    = key/kyy
  210    continue
         ico(1) = key
c                                  Set up nt array
         nt(1) = nn - ico(1)
         do 220  i=2, nco
            nt(i) = nt(i-1) - ico(i)
  220    continue
         go to 90
c
      else if (nro.gt.2 .and. nst.gt.0) then
c                                  Go to next level
         nitc = nst
         nst  = 0
         k    = ks
         ks   = ldst - ks
         nn   = nn - iro(irl)
         irl  = irl + 1
         nro  = nro - 1
         go to 200
      end if
c
      dlp = dlp - vmn
 9000 return
      end
      subroutine f4xact (nrow, irow, ncol, icol, dsp, fact, icstk,
     &                   ncstk, lstk, mstk, nstk, nrstk, irstk, ystk,
     &                   tol)
c-----------------------------------------------------------------------
c  Name:       F4XACT
c
c  Purpose:    Computes the longest path length for a given table.
c
c  Usage:      CALL F4XACT (NROW, IROW, NCOL, ICOL, DSP, FACT, ICSTK,
c                          NCSTK, LSTK, MSTK, NSTK, NRSTK, IRSTK, YSTK,
c                          TOL)
c
c  Arguments:
c     NROW   - The number of rows in the table.  (Input)
c     IROW   - Vector of length NROW containing the row sums for the
c              table.  (Input)
c     NCOL   - The number of columns in the table.  (Input)
c     ICOL   - Vector of length K containing the column sums for the
c              table.  (Input)
c     DSP    - The shortest path for the table.  (Output)
c     FACT   - Vector containing the logarithms of factorials.  (Input)
c     ICSTK  - NCOL by NROW+NCOL+1 work array.
c     NCSTK  - Work vector of length NROW+NCOL+1.
c     LSTK   - Work vector of length NROW+NCOL+1.
c     MSTK   - Work vector of length NROW+NCOL+1.
c     NSTK   - Work vector of length NROW+NCOL+1.
c     NRSTK  - Work vector of length NROW+NCOL+1.
c     IRSTK  - NROW by MAX(NROW,NCOL) work array.
c     YSTK   - Work vector of length NROW+NCOL+1.
c     TOL    - Tolerance.  (Input)
c-----------------------------------------------------------------------
c                                  SPECIFICATIONS FOR ARGUMENTS
      integer    nrow, ncol, irow(*), icol(*), icstk(ncol,*),
     &           ncstk(*), lstk(*), mstk(*), nstk(*), nrstk(*),
     &           irstk(nrow,*)
      double precision dsp, tol, fact(0:*), ystk(*)
c                                  SPECIFICATIONS FOR LOCAL VARIABLES
      integer    i, ic1, ict, ir1, irt, istk, j, k, l, m, mn, n, nco,
     &           nro
      double precision amx, y
c                                  SPECIFICATIONS FOR SUBROUTINES
      external   f11act, f8xact
c                                  Take care of the easy cases firstkt
      if (nrow .eq. 1) then
         do 10  i=1, ncol
            dsp = dsp - fact(icol(i))
   10    continue
         go to 9000
      end if
c
      if (ncol .eq. 1) then
         do 20  i=1, nrow
            dsp = dsp - fact(irow(i))
   20    continue
         go to 9000
      end if
c
      if (nrow*ncol .eq. 4) then
         if (irow(2) .le. icol(2)) then
            dsp = dsp - fact(irow(2)) - fact(icol(1)) -
     &            fact(icol(2)-irow(2))
         else
            dsp = dsp - fact(icol(2)) - fact(irow(1)) -
     &            fact(irow(2)-icol(2))
         end if
         go to 9000
      end if
c                                  initialization before loop
      do 30  i=1, nrow
         irstk(i,1) = irow(nrow-i+1)
   30 continue
c
      do 40  j=1, ncol
         icstk(j,1) = icol(ncol-j+1)
   40 continue
c
      nro      = nrow
      nco      = ncol
      nrstk(1) = nro
      ncstk(1) = nco
      ystk(1)  = 0.0
      y        = 0.0
      istk     = 1
      l        = 1
      amx      = 0.0
c
   50 ir1 = irstk(1,istk)
      ic1 = icstk(1,istk)
      if (ir1 .gt. ic1) then
         if (nro .ge. nco) then
            m = nco - 1
            n = 2
         else
            m = nro
            n = 1
         end if
      else if (ir1 .lt. ic1) then
         if (nro .le. nco) then
            m = nro - 1
            n = 1
         else
            m = nco
            n = 2
         end if
      else
         if (nro .le. nco) then
            m = nro - 1
            n = 1
         else
            m = nco - 1
            n = 2
         end if
      end if
c
   60 if (n .eq. 1) then
         i = l
         j = 1
      else
         i = 1
         j = l
      end if
c
      irt = irstk(i,istk)
      ict = icstk(j,istk)
      mn  = irt
      if (mn .gt. ict) mn = ict
      y = y + fact(mn)
      if (irt .eq. ict) then
         nro = nro - 1
         nco = nco - 1
         call f11act (irstk(1,istk), i, nro, irstk(1,istk+1))
         call f11act (icstk(1,istk), j, nco, icstk(1,istk+1))
      else if (irt .gt. ict) then
         nco = nco - 1
         call f11act (icstk(1,istk), j, nco, icstk(1,istk+1))
         call f8xact (irstk(1,istk), irt-ict, i, nro, irstk(1,istk+1))
      else
         nro = nro - 1
         call f11act (irstk(1,istk), i, nro, irstk(1,istk+1))
         call f8xact (icstk(1,istk), ict-irt, j, nco, icstk(1,istk+1))
      end if
c
      if (nro .eq. 1) then
         do 70  k=1, nco
            y = y + fact(icstk(k,istk+1))
   70    continue
         go to 90
      end if
c
      if (nco .eq. 1) then
         do 80  k=1, nro
            y = y + fact(irstk(k,istk+1))
   80    continue
         go to 90
      end if
c
      lstk(istk)  = l
      mstk(istk)  = m
      nstk(istk)  = n
      istk        = istk + 1
      nrstk(istk) = nro
      ncstk(istk) = nco
      ystk(istk)  = y
      l           = 1
      go to 50
c
   90 if (y .gt. amx) then
         amx = y
         if (dsp-amx .le. tol) then
            dsp = 0.0
            go to 9000
         end if
      end if
c
  100 istk = istk - 1
      if (istk .eq. 0) then
         dsp = dsp - amx
         if (dsp-amx .le. tol) dsp = 0.0
         go to 9000
      end if
      l = lstk(istk) + 1
c
  110 if (l .gt. mstk(istk)) go to 100
      n   = nstk(istk)
      nro = nrstk(istk)
      nco = ncstk(istk)
      y   = ystk(istk)
      if (n .eq. 1) then
         if (irstk(l,istk) .lt. irstk(l-1,istk)) go to 60
      else if (n .eq. 2) then
         if (icstk(l,istk) .lt. icstk(l-1,istk)) go to 60
      end if
c
      l = l + 1
      go to 110
 9000 return
      end
      subroutine f5xact (pastp, tol, kval, key, ldkey, ipoin, stp,
     &                   ldstp, ifrq, npoin, nr, nl, ifreq, itop, ipsh)
c-----------------------------------------------------------------------
c  Name:       F5XACT
c
c  Purpose:    Put node on stack in network algorithm.
c
c  Usage:      CALL F5XACT (PASTP, TOL, KVAL, KEY, LDKEY, IPOIN, STP,
c                          LDSTP, IFRQ, NPOIN, NR, NL, IFREQ, ITOP,
c                          IPSH)
c
c  Arguments:
c     PASTP  - The past path length.  (Input)
c     TOL    - Tolerance for equivalence of past path lengths.  (Input)
c     KVAL   - Key value.  (Input)
c     KEY    - Vector of length LDKEY containing the key values.
c              (Input/output)
c     LDKEY  - Length of vector KEY.  (Input)
c     IPOIN  - Vector of length LDKEY pointing to the linked list
c              of past path lengths.  (Input/output)
c     STP    - Vector of length LSDTP containing the linked lists
c              of past path lengths.  (Input/output)
c     LDSTP  - Length of vector STP.  (Input)
c     IFRQ   - Vector of length LDSTP containing the past path
c              frequencies.  (Input/output)
c     NPOIN  - Vector of length LDSTP containing the pointers to
c              the next past path length.  (Input/output)
c     NR     - Vector of length LDSTP containing the right object
c              pointers in the tree of past path lengths.
c              (Input/output)
c     NL     - Vector of length LDSTP containing the left object
c              pointers in the tree of past path lengths.
c              (Input/output)
c     IFREQ  - Frequency of the current path length.  (Input)
c     ITOP   - Pointer to the top of STP.  (Input)
c     IPSH   - Option parameter.  (Input)
c              If IPSH is true, the past path length is found in the
c              table KEY.  Otherwise the location of the past path
c              length is assumed known and to have been found in
c              a previous call.
c-----------------------------------------------------------------------
c                                  SPECIFICATIONS FOR ARGUMENTS
      integer    kval, ldkey, ldstp, ifreq, itop, key(*), ipoin(*),
     &           ifrq(*), npoin(*), nr(*), nl(*)
      double precision pastp, tol, stp(*)
      logical    ipsh
c                                  SPECIFICATIONS FOR LOCAL VARIABLES
      integer    ipn, ird, itmp
      double precision test1, test2
c                                  SPECIFICATIONS FOR SAVE VARIABLES
      integer    itp
      save       itp
c                                  SPECIFICATIONS FOR INTRINSICS
      intrinsic  mod
      integer    mod
c                                  SPECIFICATIONS FOR SUBROUTINES
ccccc external   prterr
c
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      if (ipsh) then
c                                  Convert KVAL to integer in range
c                                  1, ..., LDKEY.
         ird = mod(kval,ldkey) + 1
c                                  Search for an unused location
         do 10  itp=ird, ldkey
            if (key(itp) .eq. kval) go to 40
            if (key(itp) .lt. 0) go to 30
   10    continue
c
         do 20  itp=1, ird - 1
            if (key(itp) .eq. kval) go to 40
            if (key(itp) .lt. 0) go to 30
   20    continue
c                                  Return if KEY array is full
CCCCC    call prterr(6, 'LDKEY is too small for this problem.  It is '//
CCCCC&               'not possible to estimate the value of LDKEY '//
CCCCC&               'required, but twice the current value may be '//
CCCCC&               'sufficient.')
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** ERROR IN FISHER EXACT TEST.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)
 9013 FORMAT('      LDKEY is too small for this proble,.  It is not')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)
 9015 FORMAT('      possible to estimate the value of LDKEY required,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)
 9017 FORMAT('      possible to estimate the value of LDKEY required,')
      CALL DPWRST('XXX','BUG ')
c                                  Update KEY
   30    key(itp) = kval
         itop       = itop + 1
         ipoin(itp) = itop
c                                  Return if STP array full
         if (itop .gt. ldstp) then
CCCCC       call prterr(7, 'LDSTP is too small for this problem.  It '//
CCCCC&                  'is not possible to estimate the value of '//
CCCCC&                  'LDSTP required, but twice the current value '//
CCCCC&                  'may be sufficient.')
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,9111)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,9113)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,9115)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,9117)
            CALL DPWRST('XXX','BUG ')
         end if
 9111 FORMAT('***** ERROR IN FISHER EXACT TEST.')
 9113 FORMAT('      LDSTP is too small for this problem.  It is not')
 9115 FORMAT('      possible to estimate the value of LDSTP required,')
 9117 FORMAT('      but twice the current value may be sufficient.')
c                                  Update STP, etc.
         npoin(itop) = -1
         nr(itop)    = -1
         nl(itop)    = -1
         stp(itop)   = pastp
         ifrq(itop)  = ifreq
         go to 9000
      end if
c                                  Find location, if any, of pastp
   40 ipn = ipoin(itp)
      test1 = pastp - tol
      test2 = pastp + tol
c
   50 if (stp(ipn) .lt. test1) then
         ipn = nl(ipn)
         if (ipn .gt. 0) go to 50
      else if (stp(ipn) .gt. test2) then
         ipn = nr(ipn)
         if (ipn .gt. 0) go to 50
      else
         ifrq(ipn) = ifrq(ipn) + ifreq
         go to 9000
      end if
c                                  Return if STP array full
      itop = itop + 1
      if (itop .gt. ldstp) then
ccccc    call prterr(7, 'LDSTP is too small for this problem.  It is '//
ccccc&               'not possible to estimate the value of LDSTP '//
ccccc&               'rerquired, but twice the current value may be '//
ccccc&               'sufficient.')
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,9111)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,9113)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,9115)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,9117)
            CALL DPWRST('XXX','BUG ')
         go to 9000
      end if
c                                  Find location to add value
      ipn  = ipoin(itp)
      itmp = ipn
   60 if (stp(ipn) .lt. test1) then
         itmp = ipn
         ipn  = nl(ipn)
         if (ipn .gt. 0) then
            go to 60
         else
            nl(itmp) = itop
         end if
      else if (stp(ipn) .gt. test2) then
         itmp = ipn
         ipn  = nr(ipn)
         if (ipn .gt. 0) then
            go to 60
         else
            nr(itmp) = itop
         end if
      end if
c                                  Update STP, etc.
      npoin(itop) = npoin(itmp)
      npoin(itmp) = itop
      stp(itop)   = pastp
      ifrq(itop)  = ifreq
      nl(itop)    = -1
      nr(itop)    = -1
c
 9000 return
      end
      subroutine f6xact (nrow, irow, iflag, kyy, key, ldkey, last, ipn)
c-----------------------------------------------------------------------
c  Name:       F6XACT
c
c  Purpose:    Pop a node off the stack.
c
c  Usage:      CALL F6XACT (NROW, IROW, IFLAG, KYY, KEY, LDKEY, LAST,
c                          IPN)
c
c  Arguments:
c     NROW   - The number of rows in the table.  (Input)
c     IROW   - Vector of length nrow containing the row sums on output.
c              (Output)
c     IFLAG  - Set to 3 if there are no additional nodes to process.
c              (Output)
c     KYY    - Constant mutlipliers used in forming the hash table key.
c              (Input)
c     KEY    - Vector of length LDKEY containing the hash table keys.
c              (Input/output)
c     LDKEY  - Length of vector KEY.  (Input)
c     LAST   - Index of the last key popped off the stack.
c              (Input/output)
c     IPN    - Pointer to the linked list of past path lengths.
c              (Output)
c-----------------------------------------------------------------------
c                                  SPECIFICATIONS FOR ARGUMENTS
      integer    nrow, iflag, ldkey, last, ipn, irow(*), kyy(*), key(*)
c                                  SPECIFICATIONS FOR LOCAL VARIABLES
      integer    j, kval
c                                  SPECIFICATIONS FOR SAVE VARIABLES
c
   10 last = last + 1
      if (last .le. ldkey) then
         if (key(last) .lt. 0) go to 10
c                                  Get KVAL from the stack
         kval      = key(last)
         key(last) = -9999
         do 20  j=nrow, 2, -1
            irow(j) = kval/kyy(j)
            kval    = kval - irow(j)*kyy(j)
   20    continue
         irow(1) = kval
         ipn     = last
      else
         last  = 0
         iflag = 3
      end if
      return
      end
      subroutine f7xact (nrow, imax, idif, k, ks, iflag)
c-----------------------------------------------------------------------
c  Name:       F7XACT
c
c  Purpose:    Generate the new nodes for given marinal totals.
c
c  Usage:      CALL F7XACT (NROW, IMAX, IDIF, K, KS, IFLAG)
c
c  Arguments:
c     NROW   - The number of rows in the table.  (Input)
c     IMAX   - The row marginal totals.  (Input)
c     IDIF   - The column counts for the new column.  (Input/output)
c     K      - Indicator for the row to decrement.  (Input/output)
c     KS     - Indicator for the row to increment.  (Input/output)
c     IFLAG  - Status indicator.  (Output)
c              If IFLAG is zero, a new table was generated.  For
c              IFLAG = 1, no additional tables could be generated.
c-----------------------------------------------------------------------
c                                  SPECIFICATIONS FOR ARGUMENTS
      integer    nrow, k, ks, iflag, imax(*), idif(*)
c                                  SPECIFICATIONS FOR LOCAL VARIABLES
      integer    i, k1, m, mm
c                                  SPECIFICATIONS FOR INTRINSICS
      intrinsic  min0
      integer    min0
c
      iflag = 0
c                                  Find node which can be
c                                  incremented, ks
      if (ks .eq. 0) then
   10    ks = ks + 1
         if (idif(ks) .eq. imax(ks)) go to 10
      end if
c                                 Find node to decrement (>ks)
   20 if (idif(k).gt.0 .and. k.gt.ks) then
         idif(k) = idif(k) - 1
   30    k = k - 1
         if (imax(k) .eq. 0) go to 30
         m = k
c                                 Find node to increment (>=ks)
   40    if (idif(m) .ge. imax(m)) then
            m = m - 1
            go to 40
         end if
         idif(m) = idif(m) + 1
c                                 Change ks
         if (m .eq. ks) then
            if (idif(m) .eq. imax(m)) ks = k
         end if
      else
c                                 Check for finish
   50    do 60  k1=k + 1, nrow
            if (idif(k1) .gt. 0) go to 70
   60    continue
         iflag = 1
         go to 9000
c                                 Reallocate counts
   70    mm = 1
         do 80  i=1, k
            mm      = mm + idif(i)
            idif(i) = 0
   80    continue
         k = k1
   90    k = k - 1
         m       = min0(mm,imax(k))
         idif(k) = m
         mm      = mm - m
         if (mm.gt.0 .and. k.ne.1) go to 90
c                                 Check that all counts
c                                 reallocated
         if (mm .gt. 0) then
            if (k1 .ne. nrow) then
               k = k1
               go to 50
            end if
            iflag = 1
            go to 9000
         end if
c                                 Get ks
         idif(k1) = idif(k1) - 1
         ks       = 0
  100    ks = ks + 1
         if (ks .gt. k) go to 9000
         if (idif(ks) .ge. imax(ks)) go to 100
      end if
c
 9000 return
      end
      subroutine f8xact (irow, is, i1, izero, new)
c-----------------------------------------------------------------------
c  Name:       F8XACT
c
c  Purpose:    Routine for reducing a vector when there is a zero
c              element.
c
c  Usage:      CALL F8XACT (IROW, IS, I1, IZERO, NEW)
c
c  Arguments:
c     IROW   - Vector containing the row counts.  (Input)
c     IS     - Indicator.  (Input)
c     I1     - Indicator.  (Input)
c     IZERO  - Position of the zero.  (Input)
c     NEW    - Vector of new row counts.  (Output)
c-----------------------------------------------------------------------
c                                  SPECIFICATIONS FOR ARGUMENTS
      integer    is, i1, izero, irow(*), new(*)
c                                  SPECIFICATIONS FOR LOCAL VARIABLES
      integer    i
c
      do 10  i=1, i1 - 1
         new(i) = irow(i)
   10 continue
c
      do 20  i=i1, izero - 1
         if (is .ge. irow(i+1)) go to 30
         new(i) = irow(i+1)
   20 continue
c
      i = izero
   30 new(i) = is
   40 i = i + 1
      if (i .gt. izero) return
      new(i) = irow(i)
      go to 40
      end
      double precision function f9xact (n, mm, ir, fact)
c-----------------------------------------------------------------------
c  Name:       F9XACT
c
c  Purpose:    Computes the log of a multinomial coefficient.
c
c  Usage:      F9XACT(N, MM, IR, FACT)
c
c  Arguments:
c     N      - Length of IR.  (Input)
c     MM     - Number for factorial in numerator.  (Input)
c     IR     - Vector of length N containing the numebers for the
c              denominator of the factorial.  (Input)
c     FACT   - Table of log factorials.  (Input)
c     F9XACT  - The log of the multinomal coefficient.  (Output)
c-----------------------------------------------------------------------
c                                  SPECIFICATIONS FOR ARGUMENTS
      integer    n, mm, ir(*)
      double precision fact(0:*)
c                                  SPECIFICATIONS FOR LOCAL VARIABLES
      integer    k
c
      f9xact = fact(mm)
      do 10  k=1, n
         f9xact = f9xact - fact(ir(k))
   10 continue
c
      return
      end
      subroutine f10act (nrow, irow, ncol, icol, val, xmin, fact, nd,
     &                   ne, m)
c----------------------------------------------------------------------
c  Name:       F10ACT
c
c  Purpose:    Computes the shortest path length for special tables.
c
c  Usage:      CALL F10ACT(NROW, IROW, NCOL, ICOL, VAL, XMIN, FACT, ND,
c                          NE, M)
c
c  Arguments:
c     NROW   - The number of rows in the table.  (Input)
c     IROW   - Vector of length NROW containing the row totals. (Input)
c     NCOL   - The number of columns in the table.  (Input)
c     ICO    - Vector of length NCOL containing the column totals.
c              (Input)
c     VAL    - The shortest path.  (Output)
c     XMIN   - Set to true if shortest path obtained.  (Output)
c     FACT   - Vector containing the logarithms of factorials.
c              (Input)
c     ND     - Workspace vector of length NROW.
c     NE     - Workspace vector of length NCOL.
c     M      - Workspace vector of length NCOL.
c
c  Chapter:    STAT/LIBRARY Categorical and Discrete Data Analysis
c----------------------------------------------------------------------
c                                  SPECIFICATIONS FOR ARGUMENTS
      integer    nrow, ncol, irow(*), icol(*), nd(*), ne(*), m(*)
      double precision val, fact(0:*)
      logical    xmin
c                                  SPECIFICATIONS FOR LOCAL VARIABLES
      integer    i, is, ix, nrw1
c
      do 10  i=1, nrow - 1
         nd(i) = 0
   10 continue
c
      is    = icol(1)/nrow
      ne(1) = is
      ix    = icol(1) - nrow*is
      m(1)  = ix
      if (ix .ne. 0) nd(ix) = nd(ix) + 1
c
      do 20  i=2, ncol
         ix    = icol(i)/nrow
         ne(i) = ix
         is    = is + ix
         ix    = icol(i) - nrow*ix
         m(i)  = ix
         if (ix .ne. 0) nd(ix) = nd(ix) + 1
   20 continue
c
      do 30  i=nrow - 2, 1, -1
         nd(i) = nd(i) + nd(i+1)
   30 continue
c
      ix   = 0
      nrw1 = nrow + 1
      do 40  i=nrow, 2, -1
         ix = ix + is + nd(nrw1-i) - irow(i)
         if (ix .lt. 0) return
   40 continue
c
      do 50  i=1, ncol
         ix  = ne(i)
         is  = m(i)
         val = val + is*fact(ix+1) + (nrow-is)*fact(ix)
   50 continue
      xmin = .true.
c
      return
      end
      subroutine f11act (irow, i1, i2, new)
c---------------------------------------------------------------------
c  Name:       F11ACT
c
c  Purpose:    Routine for revising row totals.
c
c  Usage:      CALL F11ACT (IROW, I1, I2, NEW)
c
c  Arguments:
c     IROW   - Vector containing the row totals.  (Input)
c     I1     - Indicator.  (Input)
c     I2     - Indicator.  (Input)
c     NEW    - Vector containing the row totals.  (Input)
c----------------------------------------------------------------------
c                                  SPECIFICATIONS FOR ARGUMENTS
      integer    i1, i2, irow(*), new(*)
c                                  SPECIFICATIONS FOR LOCAL VARIABLES
      integer    i
c
      do 10  i=1, i1 - 1
         new(i) = irow(i)
   10 continue
c
      do 20  i=i1, i2
         new(i) = irow(i+1)
   20 continue
c
      return
      end
      double precision function ff (x)
c
c      NOTE: This subroutine used in computing the consensus mean
c            using the Iyer and Wang generalized tolerance interval
c            approach.
c
c            Modified for Dataplot 3/2006.
c
      implicit none
c
      double precision  x
c
      integer kk
      double precision aa, ybar, cc, bb(100), yy(100)
      common /cmn1/ kk
      common /cmn2/ aa, ybar, cc, bb, yy
c
      integer i
      double precision s1, s2, s3, s4, s5, tmp
c
      if (x .le. 0.0d0) then
          ff = aa - cc
          return
      end if
c
      s1 = 0.0d0
      s2 = 0.0d0
      s3 = 0.0d0
      s4 = 0.0d0
      s5 = 0.0d0
c
      do 10 i = 1, kk
         tmp = x + bb(i)
         s1 = s1 + yy(i)**2/tmp
         s2 = s2 + yy(i)/tmp
         s3 = s3 + 1.0d0/tmp
         s4 = s4 + yy(i)*bb(i)/tmp
         s5 = s5 + bb(i)/tmp
   10 continue
c
      ff = s1 - 2.0d0*ybar*s2 + ybar**2 * s3 - (s4 - ybar*s5)**2/
     1     (x * (kk - s5)) - cc
c
      return
      end
      SUBROUTINE FACCUR(H0,H1,FACC,X0,F,TWOINF,F0,F1)
      REAL H0,H1,FACC,A0,A1,F00,F2,DELTAF,T0,T1,X0,F,DF(5),F0,F1
     +        ,TWOINF
      INTEGER J
      EXTERNAL F
C
      INCLUDE 'DPCOMC.INC'
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      T0 = 0.
      T1 = 0.
      IF(H0.NE.0.) THEN
          IF(X0+H0.NE.0.) THEN
              F00 = F1
          ELSE
              H0 = 0.875*H0
              F00 = F(X0+H0)
          ENDIF
          IF(ABS(H1) .GE. 32.*TWOINF) H1 = H1/8.
          IF(16.*ABS(H1) .GT. ABS(H0)) H1 = SIGN(H1,1.)*ABS(H0)/16.
          IF(F(X0+H0-H1) .EQ. F00) THEN 
              IF(256.*ABS(H1) .LE. ABS(H0)) THEN
                  H1 = 2.*H1
   10             IF(F(X0+H0-H1).NE.F00 .OR. 256.*ABS(H1).GT.ABS(H0)) 
     +                    GOTO 20
                  H1 = 2.*H1
                  GOTO 10
   20             H1 = 8.*H1
  
              ELSE
                  H1 = SIGN(H1,1.)*ABS(H0)/16.
              ENDIF 
          ELSE
              IF(256.*TWOINF .LE. ABS(H0)) THEN
   30             IF(F(X0+H0-H1/2.).EQ.F00 .OR. ABS(H1).LT.4.*TWOINF) 
     +                GOTO 40 
                  H1 = H1/2.
                  GOTO 30
   40             CONTINUE
                  H1 = 8.*H1
                  IF(16.*ABS(H1) .GT. ABS(H0)) H1 = SIGN(H1,1.)
     +                     *ABS(H0)/16. 
              ELSE
                  H1 = SIGN(H1,1.)*ABS(H0)/16.
              ENDIF 
          ENDIF
      ELSE
          F00 = F0
      ENDIF
  
      DO 50 J = 1,5 
          F2 = F(X0+H0-FLOAT(2*J-1)*H1) 
          DF(J) = F2 - F00
          T0 = T0+DF(J)
          T1 = T1+FLOAT(2*J-1)*DF(J)
   50 CONTINUE
      A0 = (33.*T0-5.*T1)/73. 
      A1 = (-5.*T0+1.2*T1)/73.
      FACC = ABS(A0)
      DO 70 J = 1,5 
          DELTAF = ABS(DF(J)-(A0+FLOAT(2*J-1)*A1))
          IF(FACC.LT.DELTAF) FACC = DELTAF
   70 CONTINUE
      FACC = 2.*FACC
      RETURN
      END 
      subroutine fastg(xreal, ximag, n, itype)
c
c       Algorithm AS 83.2 Appl. Statist. (1975) vol.24, no.1
c
c       Radix 4 complex discrete fast Fourier transform without
c       unscrambling, suitable for convolutions or other applications
c       which do not require unscrambling.   Called by subroutine
c       FASTF which also does the unscrambling.
c
        implicit double precision (A-H, O-Z)
      double precision  xreal(n), ximag(n)
      data    zero, half, one, one5, two, four
     +          /0.0D0,  0.5D0, 1.0D0,  1.5D0, 2.0D0,  4.0D0/
      pi = four * atan(one)
      ifaca = n / 4
      if (itype .eq. 0) return
      if (itype .gt. 0) go to 5
c
c       ITYPE < 0 indicates inverse transform required.
c       Calculate conjugate.
c
      do 4 k = 1, n
    4   ximag(k) = -ximag(k)
c
c       Following code is executed for IFACA = N/4, N/16, N/64, ...
c       until IFACA <= 1.
c
    5   ifcab = ifaca * 4
      z = pi / ifcab
      bcos = -two * sin(z)**2
      bsin = sin(two * z)
      cw1 = one
      sw1 = zero
      do 10 litla = 1, ifaca
        do 8 i0 = litla, n, ifcab
          i1 = i0 + ifaca
          i2 = i1 + ifaca
          i3 = i2 + ifaca
          xs0 = xreal(i0) + xreal(i2)
          xs1 = xreal(i0) - xreal(i2)
          ys0 = ximag(i0) + ximag(i2)
          ys1 = ximag(i0) - ximag(i2)
          xs2 = xreal(i1) + xreal(i3)
          xs3 = xreal(i1) - xreal(i3)
          ys2 = ximag(i1) + ximag(i3)
          ys3 = ximag(i1) - ximag(i3)
          xreal(i0) = xs0 + xs2
          ximag(i0) = ys0 + ys2
          x1 = xs1 + ys3
          y1 = ys1 - xs3
          x2 = xs0 - xs2
          y2 = ys0 - ys2
          x3 = xs1 - ys3
          y3 = ys1 + xs3
          if (litla .eq. 1) then
            xreal(i2) = x1
            ximag(i2) = y1
            xreal(i1) = x2
            ximag(i1) = y2
            xreal(i3) = x3
            ximag(i3) = y3
          else
            xreal(i2) = x1 * cw1 + y1 * sw1
            ximag(i2) = y1 * cw1 - x1 * sw1
            xreal(i1) = x2 * cw2 + y2 * sw2
            ximag(i1) = y2 * cw2 - x2 * sw2
            xreal(i3) = x3 * cw3 + y3 * sw3
            ximag(i3) = y3 * cw3 - x3 * sw3
          end if
    8     continue
c
c       Calculate a new set of twiddle factors.
c
        if (litla .lt. ifaca) then
          z = cw1 * bcos - sw1 * bsin + cw1
          sw1 = bcos * sw1 + bsin * cw1 + sw1
          tempr = one5 - half * (z * z + sw1 * sw1)
          cw1 = z * tempr
          sw1 = sw1 * tempr
          cw2 = cw1 * cw1 - sw1 * sw1
          sw2 = two * cw1 * sw1
          cw3 = cw1 * cw2 - sw1 * sw2
          sw3 = cw1 * sw2 + cw2 * sw1
        end if
   10   continue
      if (ifaca .le. 1) go to 14
c
c       Set up the transform split for the next stage.
c
      ifaca = ifaca / 4
      if (ifaca .gt. 0) go to 5
c
c       Radix 2 calculation, if needed.
c
      if (ifaca .lt. 0) return
      do 13 k = 1, n, 2
        tempr = xreal(k) + xreal(k+1)
        xreal(k+1) = xreal(k) - xreal(k+1)
        xreal(k) = tempr
        tempr = ximag(k) + ximag(k+1)
        ximag(k+1) = ximag(k) - ximag(k+1)
        ximag(k) = tempr
   13   continue
   14   if (itype .lt. 0) then
c
c       Inverse transform; conjugate the result.
c
        do 16 k = 1, n
   16     ximag(k) = -ximag(k)
        return
      end if
c
c       Forward transform
c
      z = one / n
      do 18 k = 1, n
        xreal(k) = xreal(k) * z
        ximag(k) = ximag(k) * z
   18   continue
c
      return
      end
      SUBROUTINE FORRT(X, M)
C
C     ALGORITHM AS 97  APPL. STATIST. (1976) VOL.25, NO. 2
C
C     Forward discrete Fourier transform in one dimension of real
C     data using complex transform subroutine FASTG.
C
C     X = array of real input data, type real, dimension M.
C     M = length of the transform, must be a power of 2.
C     The minimum length is 8, maximum 2**21.
C
C     The result is placed in X as described in the text of the paper.
C
C     Auxiliary routines required: SCRAG (or SCRAM) & FASTG from AS 83,
C     but with SCRAG modified as described on page 168 of the paper for
C     this algorithm.
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DOUBLE PRECISION X(M)
      DATA ZERO/0.0D0/, QUART/0.25D0/, HALF/0.5D0/, ONE/1.0D0/,
     *  ONE5/1.5D0/, TWO/2.0D0/, FOUR/4.0D0/
C
C     Check for valid transform size.
C
      II = 8
      DO 2 K = 3, 21
      IPOW = K
      IF (II .EQ. M) GO TO 3
      II = II * 2
    2 CONTINUE
C
C     If this point is reached, an illegal size was specified.
C
      RETURN
    3 PIE = FOUR * ATAN(ONE)
C
C     Separate odd and even parts into two halves.
C     First bit reverse the whole array of length M.
C
      CALL SCRAG(X, M, IPOW)
C
C     Next bit reverse the half arrays separately.
C
      N = M / 2
      JPOW = IPOW - 1
      CALL SCRAG(X, N, JPOW)
      CALL SCRAG(X(N+1), N, JPOW)
C
C     Faster alternative to the two lines above to SCRAM.
C           CALL SCRAM(X, X(N+1), N, JPOW)
C
C     Now do the transform.
C
      CALL FASTG(X, X(N+1), N, 1)
C
C     Unscramble the transform results.
C
      CALL SCRAG(X, N, JPOW)
      CALL SCRAG(X(N+1), N, JPOW)
C
C     Faster alternative to the two lines above to SCRAM.
C           CALL SCRAM(X, X(N+1), N, JPOW)
C
      NN = N / 2
C
C     Now unravel the result; first the special cases.
C
      Z = HALF * (X(1) + X(N+1))
      X(N+1) = HALF * (X(1) - X(N+1))
      X(1) = Z
      NN1 = NN + 1
      NN2 = NN1 + N
      X(NN1) = HALF * X(NN1)
      X(NN2) = -HALF * X(NN2)
      Z = PIE / N
      BCOS = -TWO * (SIN(Z / TWO) **2)
      BSIN = SIN(Z)
      UN = ONE
      VN = ZERO
      DO 4 K = 2, NN
      Z = UN * BCOS + VN * BSIN + UN
      VN = VN * BCOS - UN * BSIN + VN
      SAVE1 = ONE5 - HALF * (Z * Z + VN * VN)
      UN = Z * SAVE1
      VN = VN * SAVE1
      KI = N + K
      L = N + 2 - K
      LI = N + L
      AN = QUART * (X(K) + X(L))
      BN = QUART * (X(KI) - X(LI))
      CN = QUART * (X(KI) + X(LI))
      DN = QUART * (X(L) - X(K))
      XN = UN * CN - VN * DN
      YN = UN * DN + VN * CN
      X(K) = AN + XN
      X(KI) = BN + YN
      X(L) = AN - XN
      X(LI) = YN - BN
    4 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION FULSUM(S, CENTER, HWIDTH, X, G, F)
*
****  To compute fully symmetric basic rule sum
*
      EXTERNAL F
      INTEGER S, IXCHNG, LXCHNG, I, L
      DOUBLE PRECISION CENTER(S), HWIDTH(S), X(S), G(S), F
      DOUBLE PRECISION INTSUM, GL, GI
      FULSUM = 0
*
*     Compute centrally symmetric sum for permutation of G
*
 10   INTSUM = 0
      DO 100 I = 1,S
         X(I) = CENTER(I) + G(I)*HWIDTH(I)
 100  CONTINUE
 20   INTSUM = INTSUM + F(S,X)
      DO 200 I = 1,S
         G(I) = -G(I)
         X(I) = CENTER(I) + G(I)*HWIDTH(I)
         IF ( G(I) .LT. 0 ) GO TO 20
 200  CONTINUE
      FULSUM = FULSUM + INTSUM
*     
*     Find next distinct permuation of G and loop back for next sum
*     
      DO 300 I = 2,S
         IF ( G(I-1) .GT. G(I) ) THEN
            GI = G(I)
            IXCHNG = I - 1
            DO 400 L = 1,(I-1)/2
               GL = G(L)
               G(L) = G(I-L)
               G(I-L) = GL
               IF (  GL  .LE. GI ) IXCHNG = IXCHNG - 1
               IF ( G(L) .GT. GI ) LXCHNG = L
  400       CONTINUE
            IF ( G(IXCHNG) .LE. GI ) IXCHNG = LXCHNG
            G(I) = G(IXCHNG)
            G(IXCHNG) = GI
            GO TO 10
         ENDIF
  300 CONTINUE
*     
*     End loop for permutations of G and associated sums
*     
*     Restore original order to G's
*     
      DO 500 I = 1,S/2
         GI = G(I)
         G(I) = G(S+1-I)
         G(S+1-I) = GI 
 500  CONTINUE
C
      RETURN
      END
      SUBROUTINE FZERO(F,B,C,R,RE,AE,IFLAG)
C
C   ADDED TO DATAPLOT 12/2003.  USE THIS ROUTINE FOR INTERNAL
C   COMPUTATIONS (THE ROOTS COMMAND IMPLEMENTS FOR USER DEFINED
C   FUNCTIONS).  THIS ROUTINE CAN BE MORE EFFICIENT FOR INTERNAL
C   USE SINCE WE CAN AVOID OVERHEAD OF FUNCTION PARSING, ETC.
C
C***BEGIN PROLOGUE  FZERO
C***DATE WRITTEN   700901   (YYMMDD)
C***REVISION DATE  860411   (YYMMDD)
C***CATEGORY NO.  F1B
C***KEYWORDS  BISECTION,NONLINEAR,ROOTS,ZEROS
C***AUTHOR  SHAMPINE,L.F.,SNLA
C           WATTS,H.A.,SNLA
C***PURPOSE  FZERO searches for a zero of a function F(X) in a given
C            interval (B,C).  It is designed primarily for problems
C            where F(B) and F(C) have opposite signs.
C***DESCRIPTION
C
C    From the book "Numerical Methods and Software"
C       by  D. Kahaner, C. Moler, S. Nash
C           Prentice Hall 1988
C
C     Based on a method by T J Dekker
C     written by L F Shampine and H A Watts
C
C            FZERO searches for a zero of a function F(X) between
C            the given values B and C until the width of the interval
C            (B,C) has collapsed to within a tolerance specified by
C            the stopping criterion, ABS(B-C) .LE. 2.*(RW*ABS(B)+AE).
C            The method used is an efficient combination of bisection
C            and the secant rule.
C
C     Description Of Arguments
C
C     F,B,C,R,RE and AE are input parameters
C     B,C and IFLAG are output parameters (flagged by an * below)
C
C        F     - Name of the real valued external function.  This name
C                must be in an EXTERNAL statement in the calling
C                program.  F must be a function of one real argument.
C
C       *B     - One end of the interval (B,C).  The value returned for
C                B usually is the better approximation to a zero of F.
C
C       *C     - The other end of the interval (B,C)
C
C        R     - A (better) guess of a zero of F which could help in
C                speeding up convergence.  If F(B) and F(R) have
C                opposite signs, a root will be found in the interval
C                (B,R); if not, but F(R) and F(C) have opposite
C                signs, a root will be found in the interval (R,C);
C                otherwise, the interval (B,C) will be searched for a
C                possible root.  When no better guess is known, it is
C                recommended that r be set to B or C; because if R is
C                not interior to the interval (B,C), it will be ignored.
C
C        RE    - Relative error used for RW in the stopping criterion.
C                If the requested RE is less than machine precision,
C                then RW is set to approximately machine precision.
C
C        AE    - Absolute error used in the stopping criterion.  If the
C                given interval (B,C) contains the origin, then a
C                nonzero value should be chosen for AE.
C
C       *IFLAG - A status code.  User must check IFLAG after each call.
C                Control returns to the user from FZERO in all cases.
C
C                1  B is within the requested tolerance of a zero.
C                   The interval (B,C) collapsed to the requested
C                   tolerance, the function changes sign in (B,C), and
C                   F(X) decreased in magnitude as (B,C) collapsed.
C
C                2  F(B) = 0.  However, the interval (B,C) may not have
C                   collapsed to the requested tolerance.
C
C                3  B may be near a singular point of F(X).
C                   The interval (B,C) collapsed to the requested tol-
C                   erance and the function changes sign in (B,C), but
C                   F(X) increased in magnitude as (B,C) collapsed,i.e.
C                     abs(F(B out)) .GT. max(abs(F(B in)),abs(F(C in)))
C
C                4  No change in sign of F(X) was found although the
C                   interval (B,C) collapsed to the requested tolerance.
C                   The user must examine this case and decide whether
C                   B is near a local minimum of F(X), or B is near a
C                   zero of even multiplicity, or neither of these.
C
C                5  Too many (.GT. 500) function evaluations used.
C***REFERENCES  L. F. SHAMPINE AND H. A. WATTS, *FZERO, A ROOT-SOLVING
C                 CODE*, SC-TM-70-631, SEPTEMBER 1970.
C               T. J. DEKKER, *FINDING A ZERO BY MEANS OF SUCCESSIVE
C                 LINEAR INTERPOLATION*, 'CONSTRUCTIVE ASPECTS OF THE
C                 FUNDAMENTAL THEOREM OF ALGEBRA', EDITED BY B. DEJON
C                 P. HENRICI, 1969.
C***ROUTINES CALLED  R1MACH
C***END PROLOGUE  FZERO
      REAL A,ACBS,ACMB,AE,AW,B,C,CMB,ER,FA,FB,FC,FX,FZ,P,Q,R
      REAL RE,RW,T,TOL,Z
      INTEGER IC,IFLAG,KOUNT
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     ER IS TWO TIMES THE COMPUTER UNIT ROUNDOFF VALUE WHICH IS
C     DEFINED HERE BY THE FUNCTION R1MACH.
C
C***FIRST EXECUTABLE STATEMENT  FZERO
      ER = 2.0E0 * R1MACH(4)
C
C     INITIALIZE
C
      Z=R
      IF(R.LE.AMIN1(B,C).OR.R.GE.AMAX1(B,C)) Z=C
      RW=AMAX1(RE,ER)
      AW=AMAX1(AE,0.0)
      IC=0
      T=Z
      FZ=F(T)
      FC=FZ
      T=B
      FB=F(T)
      KOUNT=2
      IF(SIGN(1.0E0,FZ).EQ.SIGN(1.0E0,FB)) GO TO 1
      C=Z
      GO TO 2
    1 IF(Z.EQ.C) GO TO 2
      T=C
      FC=F(T)
      KOUNT=3
      IF(SIGN(1.0E0,FZ).EQ.SIGN(1.0E0,FC)) GO TO 2
      B=Z
      FB=FZ
    2 A=C
      FA=FC
      ACBS=ABS(B-C)
      FX=AMAX1(ABS(FB),ABS(FC))
C
    3 IF (ABS(FC) .GE. ABS(FB)) GO TO 4
C     PERFORM INTERCHANGE
      A=B
      FA=FB
      B=C
      FB=FC
      C=A
      FC=FA
C
    4 CMB=0.5*(C-B)
      ACMB=ABS(CMB)
      TOL=RW*ABS(B)+AW
C
C     TEST STOPPING CRITERION AND FUNCTION COUNT
C
      IF (ACMB .LE. TOL) GO TO 10
      IF(FB.EQ.0.E0) GO TO 11
      IF(KOUNT.GE.500) GO TO 14
C
C     CALCULATE NEW ITERATE IMPLICITLY AS B+P/Q
C     WHERE WE ARRANGE P .GE. 0.
C     THE IMPLICIT FORM IS USED TO PREVENT OVERFLOW.
C
      P=(B-A)*FB
      Q=FA-FB
      IF (P .GE. 0.) GO TO 5
      P=-P
      Q=-Q
C
C     UPDATE A AND CHECK FOR SATISFACTORY REDUCTION
C     IN THE SIZE OF THE BRACKETING INTERVAL.
C     IF NOT, PERFORM BISECTION.
C
    5 A=B
      FA=FB
      IC=IC+1
      IF (IC .LT. 4) GO TO 6
      IF (8.*ACMB .GE. ACBS) GO TO 8
      IC=0
      ACBS=ACMB
C
C     TEST FOR TOO SMALL A CHANGE
C
    6 IF (P .GT. ABS(Q)*TOL) GO TO 7
C
C     INCREMENT BY TOLERANCE
C
      B=B+SIGN(TOL,CMB)
      GO TO 9
C
C     ROOT OUGHT TO BE BETWEEN B AND (C+B)/2.
C
    7 IF (P .GE. CMB*Q) GO TO 8
C
C     USE SECANT RULE
C
      B=B+P/Q
      GO TO 9
C
C     USE BISECTION
C
    8 B=0.5*(C+B)
C
C     HAVE COMPLETED COMPUTATION FOR NEW ITERATE B
C
    9 T=B
      FB=F(T)
      KOUNT=KOUNT+1
C
C     DECIDE WHETHER NEXT STEP IS INTERPOLATION OR EXTRAPOLATION
C
      IF (SIGN(1.0,FB) .NE. SIGN(1.0,FC)) GO TO 3
      C=A
      FC=FA
      GO TO 3
C
C
C     FINISHED. PROCESS RESULTS FOR PROPER SETTING OF IFLAG
C
   10 IF (SIGN(1.0,FB) .EQ. SIGN(1.0,FC)) GO TO 13
      IF (ABS(FB) .GT. FX) GO TO 12
      IFLAG = 1
      RETURN
   11 IFLAG = 2
      RETURN
   12 IFLAG = 3
      RETURN
   13 IFLAG = 4
      RETURN
   14 IFLAG = 5
      RETURN
      END
      SUBROUTINE FZEROY(F,B,C,R,RE,AE,IFLAG,XTEMP,YTEMP)
C
C   ADDED TO DATAPLOT 12/2003.  USE THIS ROUTINE FOR INTERNAL
C   COMPUTATIONS (THE ROOTS COMMAND IMPLEMENTS FOR USER DEFINED
C   FUNCTIONS).  THIS ROUTINE CAN BE MORE EFFICIENT FOR INTERNAL
C   USE SINCE WE CAN AVOID OVERHEAD OF FUNCTION PARSING, ETC.
C
C   COPY OF FZERO.  ADDS XTEMP AND YTEMP TO FUNCTION CALL
C   (NEEDED BY DPMLYU AND DPMLWA).
C
C***BEGIN PROLOGUE  FZERO
C***DATE WRITTEN   700901   (YYMMDD)
C***REVISION DATE  860411   (YYMMDD)
C***CATEGORY NO.  F1B
C***KEYWORDS  BISECTION,NONLINEAR,ROOTS,ZEROS
C***AUTHOR  SHAMPINE,L.F.,SNLA
C           WATTS,H.A.,SNLA
C***PURPOSE  FZERO searches for a zero of a function F(X) in a given
C            interval (B,C).  It is designed primarily for problems
C            where F(B) and F(C) have opposite signs.
C***DESCRIPTION
C
C    From the book "Numerical Methods and Software"
C       by  D. Kahaner, C. Moler, S. Nash
C           Prentice Hall 1988
C
C     Based on a method by T J Dekker
C     written by L F Shampine and H A Watts
C
C            FZERO searches for a zero of a function F(X) between
C            the given values B and C until the width of the interval
C            (B,C) has collapsed to within a tolerance specified by
C            the stopping criterion, ABS(B-C) .LE. 2.*(RW*ABS(B)+AE).
C            The method used is an efficient combination of bisection
C            and the secant rule.
C
C     Description Of Arguments
C
C     F,B,C,R,RE and AE are input parameters
C     B,C and IFLAG are output parameters (flagged by an * below)
C
C        F     - Name of the real valued external function.  This name
C                must be in an EXTERNAL statement in the calling
C                program.  F must be a function of one real argument.
C
C       *B     - One end of the interval (B,C).  The value returned for
C                B usually is the better approximation to a zero of F.
C
C       *C     - The other end of the interval (B,C)
C
C        R     - A (better) guess of a zero of F which could help in
C                speeding up convergence.  If F(B) and F(R) have
C                opposite signs, a root will be found in the interval
C                (B,R); if not, but F(R) and F(C) have opposite
C                signs, a root will be found in the interval (R,C);
C                otherwise, the interval (B,C) will be searched for a
C                possible root.  When no better guess is known, it is
C                recommended that r be set to B or C; because if R is
C                not interior to the interval (B,C), it will be ignored.
C
C        RE    - Relative error used for RW in the stopping criterion.
C                If the requested RE is less than machine precision,
C                then RW is set to approximately machine precision.
C
C        AE    - Absolute error used in the stopping criterion.  If the
C                given interval (B,C) contains the origin, then a
C                nonzero value should be chosen for AE.
C
C       *IFLAG - A status code.  User must check IFLAG after each call.
C                Control returns to the user from FZERO in all cases.
C
C                1  B is within the requested tolerance of a zero.
C                   The interval (B,C) collapsed to the requested
C                   tolerance, the function changes sign in (B,C), and
C                   F(X) decreased in magnitude as (B,C) collapsed.
C
C                2  F(B) = 0.  However, the interval (B,C) may not have
C                   collapsed to the requested tolerance.
C
C                3  B may be near a singular point of F(X).
C                   The interval (B,C) collapsed to the requested tol-
C                   erance and the function changes sign in (B,C), but
C                   F(X) increased in magnitude as (B,C) collapsed,i.e.
C                     abs(F(B out)) .GT. max(abs(F(B in)),abs(F(C in)))
C
C                4  No change in sign of F(X) was found although the
C                   interval (B,C) collapsed to the requested tolerance.
C                   The user must examine this case and decide whether
C                   B is near a local minimum of F(X), or B is near a
C                   zero of even multiplicity, or neither of these.
C
C                5  Too many (.GT. 500) function evaluations used.
C***REFERENCES  L. F. SHAMPINE AND H. A. WATTS, *FZERO, A ROOT-SOLVING
C                 CODE*, SC-TM-70-631, SEPTEMBER 1970.
C               T. J. DEKKER, *FINDING A ZERO BY MEANS OF SUCCESSIVE
C                 LINEAR INTERPOLATION*, 'CONSTRUCTIVE ASPECTS OF THE
C                 FUNDAMENTAL THEOREM OF ALGEBRA', EDITED BY B. DEJON
C                 P. HENRICI, 1969.
C***ROUTINES CALLED  R1MACH
C***END PROLOGUE  FZERO
      REAL A,ACBS,ACMB,AE,AW,B,C,CMB,ER,FA,FB,FC,FX,FZ,P,Q,R
      REAL RE,RW,T,TOL,Z
      INTEGER IC,IFLAG,KOUNT
C
      REAL YTEMP(*)
      REAL XTEMP(*)
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     ER IS TWO TIMES THE COMPUTER UNIT ROUNDOFF VALUE WHICH IS
C     DEFINED HERE BY THE FUNCTION R1MACH.
C
C***FIRST EXECUTABLE STATEMENT  FZERO
      ER = 2.0E0 * R1MACH(4)
C
C     INITIALIZE
C
      Z=R
      IF(R.LE.AMIN1(B,C).OR.R.GE.AMAX1(B,C)) Z=C
      RW=AMAX1(RE,ER)
      AW=AMAX1(AE,0.0)
      IC=0
      T=Z
      FZ=F(T,XTEMP,YTEMP)
      FC=FZ
      T=B
      FB=F(T,XTEMP,YTEMP)
      KOUNT=2
      IF(SIGN(1.0E0,FZ).EQ.SIGN(1.0E0,FB)) GO TO 1
      C=Z
      GO TO 2
    1 IF(Z.EQ.C) GO TO 2
      T=C
      FC=F(T,XTEMP,YTEMP)
      KOUNT=3
      IF(SIGN(1.0E0,FZ).EQ.SIGN(1.0E0,FC)) GO TO 2
      B=Z
      FB=FZ
    2 A=C
      FA=FC
      ACBS=ABS(B-C)
      FX=AMAX1(ABS(FB),ABS(FC))
C
    3 IF (ABS(FC) .GE. ABS(FB)) GO TO 4
C     PERFORM INTERCHANGE
      A=B
      FA=FB
      B=C
      FB=FC
      C=A
      FC=FA
C
    4 CMB=0.5*(C-B)
      ACMB=ABS(CMB)
      TOL=RW*ABS(B)+AW
C
C     TEST STOPPING CRITERION AND FUNCTION COUNT
C
      IF (ACMB .LE. TOL) GO TO 10
      IF(FB.EQ.0.E0) GO TO 11
      IF(KOUNT.GE.500) GO TO 14
C
C     CALCULATE NEW ITERATE IMPLICITLY AS B+P/Q
C     WHERE WE ARRANGE P .GE. 0.
C     THE IMPLICIT FORM IS USED TO PREVENT OVERFLOW.
C
      P=(B-A)*FB
      Q=FA-FB
      IF (P .GE. 0.) GO TO 5
      P=-P
      Q=-Q
C
C     UPDATE A AND CHECK FOR SATISFACTORY REDUCTION
C     IN THE SIZE OF THE BRACKETING INTERVAL.
C     IF NOT, PERFORM BISECTION.
C
    5 A=B
      FA=FB
      IC=IC+1
      IF (IC .LT. 4) GO TO 6
      IF (8.*ACMB .GE. ACBS) GO TO 8
      IC=0
      ACBS=ACMB
C
C     TEST FOR TOO SMALL A CHANGE
C
    6 IF (P .GT. ABS(Q)*TOL) GO TO 7
C
C     INCREMENT BY TOLERANCE
C
      B=B+SIGN(TOL,CMB)
      GO TO 9
C
C     ROOT OUGHT TO BE BETWEEN B AND (C+B)/2.
C
    7 IF (P .GE. CMB*Q) GO TO 8
C
C     USE SECANT RULE
C
      B=B+P/Q
      GO TO 9
C
C     USE BISECTION
C
    8 B=0.5*(C+B)
C
C     HAVE COMPLETED COMPUTATION FOR NEW ITERATE B
C
    9 T=B
      FB=F(T,XTEMP,YTEMP)
      KOUNT=KOUNT+1
C
C     DECIDE WHETHER NEXT STEP IS INTERPOLATION OR EXTRAPOLATION
C
      IF (SIGN(1.0,FB) .NE. SIGN(1.0,FC)) GO TO 3
      C=A
      FC=FA
      GO TO 3
C
C
C     FINISHED. PROCESS RESULTS FOR PROPER SETTING OF IFLAG
C
   10 IF (SIGN(1.0,FB) .EQ. SIGN(1.0,FC)) GO TO 13
      IF (ABS(FB) .GT. FX) GO TO 12
      IFLAG = 1
      RETURN
   11 IFLAG = 2
      RETURN
   12 IFLAG = 3
      RETURN
   13 IFLAG = 4
      RETURN
   14 IFLAG = 5
      RETURN
      END
