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 UPDATED --OCTOBER 2006. CALL LIST TO TCDF 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,REAL(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 UPDATED --OCTOBER 2006. CALL LIST TO TPDF 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,REAL(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 UPDATED --OCTOBER 2006. CALL LIST TO TPPF 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,REAL(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