SUBROUTINE DMATH1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES C FOR MATH SYMBOLS (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-921-3651 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(150) DIMENSION IXMAXD(150) DIMENSION IXDELD(150) DIMENSION ISTARD(150) DIMENSION NUMCOO(150) C C-----COMMON---------------------------------------------------------- C 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-----DATA STATEMENTS------------------------------------------------- C DEFINE CHARACTER 2220--/ (SLASH) C DATA IOPERA( 1),IX( 1),IY( 1)/'MOVE', 9, 16/ DATA IOPERA( 2),IX( 2),IY( 2)/'DRAW', -9, -16/ C DATA IXMIND( 1)/ -11/ DATA IXMAXD( 1)/ 11/ DATA IXDELD( 1)/ 22/ DATA ISTARD( 1)/ 1/ DATA NUMCOO( 1)/ 2/ C C DEFINE CHARACTER 2221--( (LEFT PARENTHESES) C DATA IOPERA( 3),IX( 3),IY( 3)/'MOVE', 4, 16/ DATA IOPERA( 4),IX( 4),IY( 4)/'DRAW', 2, 14/ DATA IOPERA( 5),IX( 5),IY( 5)/'DRAW', 0, 11/ DATA IOPERA( 6),IX( 6),IY( 6)/'DRAW', -2, 7/ DATA IOPERA( 7),IX( 7),IY( 7)/'DRAW', -3, 2/ DATA IOPERA( 8),IX( 8),IY( 8)/'DRAW', -3, -2/ DATA IOPERA( 9),IX( 9),IY( 9)/'DRAW', -2, -7/ DATA IOPERA( 10),IX( 10),IY( 10)/'DRAW', 0, -11/ DATA IOPERA( 11),IX( 11),IY( 11)/'DRAW', 2, -14/ DATA IOPERA( 12),IX( 12),IY( 12)/'DRAW', 4, -16/ DATA IOPERA( 13),IX( 13),IY( 13)/'MOVE', 2, 14/ DATA IOPERA( 14),IX( 14),IY( 14)/'DRAW', 0, 10/ DATA IOPERA( 15),IX( 15),IY( 15)/'DRAW', -1, 7/ DATA IOPERA( 16),IX( 16),IY( 16)/'DRAW', -2, 2/ DATA IOPERA( 17),IX( 17),IY( 17)/'DRAW', -2, -2/ DATA IOPERA( 18),IX( 18),IY( 18)/'DRAW', -1, -7/ DATA IOPERA( 19),IX( 19),IY( 19)/'DRAW', 0, -10/ DATA IOPERA( 20),IX( 20),IY( 20)/'DRAW', 2, -14/ C DATA IXMIND( 2)/ -7/ DATA IXMAXD( 2)/ 7/ DATA IXDELD( 2)/ 14/ DATA ISTARD( 2)/ 3/ DATA NUMCOO( 2)/ 18/ C C DEFINE CHARACTER 2222--) (RIGHT PARENTHESES) C DATA IOPERA( 21),IX( 21),IY( 21)/'MOVE', -4, 16/ DATA IOPERA( 22),IX( 22),IY( 22)/'DRAW', -2, 14/ DATA IOPERA( 23),IX( 23),IY( 23)/'DRAW', 0, 11/ DATA IOPERA( 24),IX( 24),IY( 24)/'DRAW', 2, 7/ DATA IOPERA( 25),IX( 25),IY( 25)/'DRAW', 3, 2/ DATA IOPERA( 26),IX( 26),IY( 26)/'DRAW', 3, -2/ DATA IOPERA( 27),IX( 27),IY( 27)/'DRAW', 2, -7/ DATA IOPERA( 28),IX( 28),IY( 28)/'DRAW', 0, -11/ DATA IOPERA( 29),IX( 29),IY( 29)/'DRAW', -2, -14/ DATA IOPERA( 30),IX( 30),IY( 30)/'DRAW', -4, -16/ DATA IOPERA( 31),IX( 31),IY( 31)/'MOVE', -2, 14/ DATA IOPERA( 32),IX( 32),IY( 32)/'DRAW', 0, 10/ DATA IOPERA( 33),IX( 33),IY( 33)/'DRAW', 1, 7/ DATA IOPERA( 34),IX( 34),IY( 34)/'DRAW', 2, 2/ DATA IOPERA( 35),IX( 35),IY( 35)/'DRAW', 2, -2/ DATA IOPERA( 36),IX( 36),IY( 36)/'DRAW', 1, -7/ DATA IOPERA( 37),IX( 37),IY( 37)/'DRAW', 0, -10/ DATA IOPERA( 38),IX( 38),IY( 38)/'DRAW', -2, -14/ C DATA IXMIND( 3)/ -7/ DATA IXMAXD( 3)/ 7/ DATA IXDELD( 3)/ 14/ DATA ISTARD( 3)/ 21/ DATA NUMCOO( 3)/ 18/ C C DEFINE CHARACTER 2223--LBRACKET (LEFT BRACKET) C DATA IOPERA( 39),IX( 39),IY( 39)/'MOVE', -3, 16/ DATA IOPERA( 40),IX( 40),IY( 40)/'DRAW', -3, -16/ DATA IOPERA( 41),IX( 41),IY( 41)/'MOVE', -2, 16/ DATA IOPERA( 42),IX( 42),IY( 42)/'DRAW', -2, -16/ DATA IOPERA( 43),IX( 43),IY( 43)/'MOVE', -3, 16/ DATA IOPERA( 44),IX( 44),IY( 44)/'DRAW', 4, 16/ DATA IOPERA( 45),IX( 45),IY( 45)/'MOVE', -3, -16/ DATA IOPERA( 46),IX( 46),IY( 46)/'DRAW', 4, -16/ C DATA IXMIND( 4)/ -7/ DATA IXMAXD( 4)/ 7/ DATA IXDELD( 4)/ 14/ DATA ISTARD( 4)/ 39/ DATA NUMCOO( 4)/ 8/ C C DEFINE CHARACTER 2224--RBRACKET (RIGHT BRACKET) C DATA IOPERA( 47),IX( 47),IY( 47)/'MOVE', 2, 16/ DATA IOPERA( 48),IX( 48),IY( 48)/'DRAW', 2, -16/ DATA IOPERA( 49),IX( 49),IY( 49)/'MOVE', 3, 16/ DATA IOPERA( 50),IX( 50),IY( 50)/'DRAW', 3, -16/ DATA IOPERA( 51),IX( 51),IY( 51)/'MOVE', -4, 16/ DATA IOPERA( 52),IX( 52),IY( 52)/'DRAW', 3, 16/ DATA IOPERA( 53),IX( 53),IY( 53)/'MOVE', -4, -16/ DATA IOPERA( 54),IX( 54),IY( 54)/'DRAW', 3, -16/ C DATA IXMIND( 5)/ -7/ DATA IXMAXD( 5)/ 7/ DATA IXDELD( 5)/ 14/ DATA ISTARD( 5)/ 47/ DATA NUMCOO( 5)/ 8/ C C DEFINE CHARACTER 2225--LBRACE (LEFT BRACE) C DATA IOPERA( 55),IX( 55),IY( 55)/'MOVE', 2, 16/ DATA IOPERA( 56),IX( 56),IY( 56)/'DRAW', 0, 15/ DATA IOPERA( 57),IX( 57),IY( 57)/'DRAW', -1, 14/ DATA IOPERA( 58),IX( 58),IY( 58)/'DRAW', -2, 12/ DATA IOPERA( 59),IX( 59),IY( 59)/'DRAW', -2, 10/ DATA IOPERA( 60),IX( 60),IY( 60)/'DRAW', -1, 8/ DATA IOPERA( 61),IX( 61),IY( 61)/'DRAW', 0, 7/ DATA IOPERA( 62),IX( 62),IY( 62)/'DRAW', 1, 5/ DATA IOPERA( 63),IX( 63),IY( 63)/'DRAW', 1, 3/ DATA IOPERA( 64),IX( 64),IY( 64)/'DRAW', -1, 1/ DATA IOPERA( 65),IX( 65),IY( 65)/'MOVE', 0, 15/ DATA IOPERA( 66),IX( 66),IY( 66)/'DRAW', -1, 13/ DATA IOPERA( 67),IX( 67),IY( 67)/'DRAW', -1, 11/ DATA IOPERA( 68),IX( 68),IY( 68)/'DRAW', 0, 9/ DATA IOPERA( 69),IX( 69),IY( 69)/'DRAW', 1, 8/ DATA IOPERA( 70),IX( 70),IY( 70)/'DRAW', 2, 6/ DATA IOPERA( 71),IX( 71),IY( 71)/'DRAW', 2, 4/ DATA IOPERA( 72),IX( 72),IY( 72)/'DRAW', 1, 2/ DATA IOPERA( 73),IX( 73),IY( 73)/'DRAW', -3, 0/ DATA IOPERA( 74),IX( 74),IY( 74)/'DRAW', 1, -2/ DATA IOPERA( 75),IX( 75),IY( 75)/'DRAW', 2, -4/ DATA IOPERA( 76),IX( 76),IY( 76)/'DRAW', 2, -6/ DATA IOPERA( 77),IX( 77),IY( 77)/'DRAW', 1, -8/ DATA IOPERA( 78),IX( 78),IY( 78)/'DRAW', 0, -9/ DATA IOPERA( 79),IX( 79),IY( 79)/'DRAW', -1, -11/ DATA IOPERA( 80),IX( 80),IY( 80)/'DRAW', -1, -13/ DATA IOPERA( 81),IX( 81),IY( 81)/'DRAW', 0, -15/ DATA IOPERA( 82),IX( 82),IY( 82)/'MOVE', -1, -1/ DATA IOPERA( 83),IX( 83),IY( 83)/'DRAW', 1, -3/ DATA IOPERA( 84),IX( 84),IY( 84)/'DRAW', 1, -5/ DATA IOPERA( 85),IX( 85),IY( 85)/'DRAW', 0, -7/ DATA IOPERA( 86),IX( 86),IY( 86)/'DRAW', -1, -8/ DATA IOPERA( 87),IX( 87),IY( 87)/'DRAW', -2, -10/ DATA IOPERA( 88),IX( 88),IY( 88)/'DRAW', -2, -12/ DATA IOPERA( 89),IX( 89),IY( 89)/'DRAW', -1, -14/ DATA IOPERA( 90),IX( 90),IY( 90)/'DRAW', 0, -15/ DATA IOPERA( 91),IX( 91),IY( 91)/'DRAW', 2, -16/ C DATA IXMIND( 6)/ -7/ DATA IXMAXD( 6)/ 7/ DATA IXDELD( 6)/ 14/ DATA ISTARD( 6)/ 55/ DATA NUMCOO( 6)/ 37/ C C DEFINE CHARACTER 2226--RBRACE (RIGHT BRACE) C DATA IOPERA( 92),IX( 92),IY( 92)/'MOVE', -2, 16/ DATA IOPERA( 93),IX( 93),IY( 93)/'DRAW', 0, 15/ DATA IOPERA( 94),IX( 94),IY( 94)/'DRAW', 1, 14/ DATA IOPERA( 95),IX( 95),IY( 95)/'DRAW', 2, 12/ DATA IOPERA( 96),IX( 96),IY( 96)/'DRAW', 2, 10/ DATA IOPERA( 97),IX( 97),IY( 97)/'DRAW', 1, 8/ DATA IOPERA( 98),IX( 98),IY( 98)/'DRAW', 0, 7/ DATA IOPERA( 99),IX( 99),IY( 99)/'DRAW', -1, 5/ DATA IOPERA( 100),IX( 100),IY( 100)/'DRAW', -1, 3/ DATA IOPERA( 101),IX( 101),IY( 101)/'DRAW', 1, 1/ DATA IOPERA( 102),IX( 102),IY( 102)/'MOVE', 0, 15/ DATA IOPERA( 103),IX( 103),IY( 103)/'DRAW', 1, 13/ DATA IOPERA( 104),IX( 104),IY( 104)/'DRAW', 1, 11/ DATA IOPERA( 105),IX( 105),IY( 105)/'DRAW', 0, 9/ DATA IOPERA( 106),IX( 106),IY( 106)/'DRAW', -1, 8/ DATA IOPERA( 107),IX( 107),IY( 107)/'DRAW', -2, 6/ DATA IOPERA( 108),IX( 108),IY( 108)/'DRAW', -2, 4/ DATA IOPERA( 109),IX( 109),IY( 109)/'DRAW', -1, 2/ DATA IOPERA( 110),IX( 110),IY( 110)/'DRAW', 3, 0/ DATA IOPERA( 111),IX( 111),IY( 111)/'DRAW', -1, -2/ DATA IOPERA( 112),IX( 112),IY( 112)/'DRAW', -2, -4/ DATA IOPERA( 113),IX( 113),IY( 113)/'DRAW', -2, -6/ DATA IOPERA( 114),IX( 114),IY( 114)/'DRAW', -1, -8/ DATA IOPERA( 115),IX( 115),IY( 115)/'DRAW', 0, -9/ DATA IOPERA( 116),IX( 116),IY( 116)/'DRAW', 1, -11/ DATA IOPERA( 117),IX( 117),IY( 117)/'DRAW', 1, -13/ DATA IOPERA( 118),IX( 118),IY( 118)/'DRAW', 0, -15/ DATA IOPERA( 119),IX( 119),IY( 119)/'MOVE', 1, -1/ DATA IOPERA( 120),IX( 120),IY( 120)/'DRAW', -1, -3/ DATA IOPERA( 121),IX( 121),IY( 121)/'DRAW', -1, -5/ DATA IOPERA( 122),IX( 122),IY( 122)/'DRAW', 0, -7/ DATA IOPERA( 123),IX( 123),IY( 123)/'DRAW', 1, -8/ DATA IOPERA( 124),IX( 124),IY( 124)/'DRAW', 2, -10/ DATA IOPERA( 125),IX( 125),IY( 125)/'DRAW', 2, -12/ DATA IOPERA( 126),IX( 126),IY( 126)/'DRAW', 1, -14/ DATA IOPERA( 127),IX( 127),IY( 127)/'DRAW', 0, -15/ DATA IOPERA( 128),IX( 128),IY( 128)/'DRAW', -2, -16/ C DATA IXMIND( 7)/ -7/ DATA IXMAXD( 7)/ 7/ DATA IXDELD( 7)/ 14/ DATA ISTARD( 7)/ 92/ DATA NUMCOO( 7)/ 37/ C C DEFINE CHARACTER 2227--LELBOW (LEFT ELBOW) C DATA IOPERA( 129),IX( 129),IY( 129)/'MOVE', 3, 16/ DATA IOPERA( 130),IX( 130),IY( 130)/'DRAW', -4, 0/ DATA IOPERA( 131),IX( 131),IY( 131)/'DRAW', 3, -16/ C DATA IXMIND( 8)/ -7/ DATA IXMAXD( 8)/ 7/ DATA IXDELD( 8)/ 14/ DATA ISTARD( 8)/ 129/ DATA NUMCOO( 8)/ 3/ C C DEFINE CHARACTER 2228--RELBOW (RIGHT ELBOW) C DATA IOPERA( 132),IX( 132),IY( 132)/'MOVE', -3, 16/ DATA IOPERA( 133),IX( 133),IY( 133)/'DRAW', 4, 0/ DATA IOPERA( 134),IX( 134),IY( 134)/'DRAW', -3, -16/ C DATA IXMIND( 9)/ -7/ DATA IXMAXD( 9)/ 7/ DATA IXDELD( 9)/ 14/ DATA ISTARD( 9)/ 132/ DATA NUMCOO( 9)/ 3/ C C DEFINE CHARACTER 2229--VBAR (VERTICAL BAR) C DATA IOPERA( 135),IX( 135),IY( 135)/'MOVE', 0, 16/ DATA IOPERA( 136),IX( 136),IY( 136)/'DRAW', 0, -16/ C DATA IXMIND( 10)/ -4/ DATA IXMAXD( 10)/ 4/ DATA IXDELD( 10)/ 8/ DATA ISTARD( 10)/ 135/ DATA NUMCOO( 10)/ 2/ C C DEFINE CHARACTER 2230--DVBAR (DOUBLE VERTICAL BAR) C DATA IOPERA( 137),IX( 137),IY( 137)/'MOVE', -3, 16/ DATA IOPERA( 138),IX( 138),IY( 138)/'DRAW', -3, -16/ DATA IOPERA( 139),IX( 139),IY( 139)/'MOVE', 3, 16/ DATA IOPERA( 140),IX( 140),IY( 140)/'DRAW', 3, -16/ C DATA IXMIND( 11)/ -7/ DATA IXMAXD( 11)/ 7/ DATA IXDELD( 11)/ 14/ DATA ISTARD( 11)/ 137/ DATA NUMCOO( 11)/ 4/ C C DEFINE CHARACTER 2231--- (MINUS SIGN) C DATA IOPERA( 141),IX( 141),IY( 141)/'MOVE', -9, 0/ DATA IOPERA( 142),IX( 142),IY( 142)/'DRAW', 9, 0/ C DATA IXMIND( 12)/ -13/ DATA IXMAXD( 12)/ 13/ DATA IXDELD( 12)/ 26/ DATA ISTARD( 12)/ 141/ DATA NUMCOO( 12)/ 2/ C C DEFINE CHARACTER 2232--+ (PLUS SIGN) C DATA IOPERA( 143),IX( 143),IY( 143)/'MOVE', 0, 9/ DATA IOPERA( 144),IX( 144),IY( 144)/'DRAW', 0, -9/ DATA IOPERA( 145),IX( 145),IY( 145)/'MOVE', -9, 0/ DATA IOPERA( 146),IX( 146),IY( 146)/'DRAW', 9, 0/ C DATA IXMIND( 13)/ -13/ DATA IXMAXD( 13)/ 13/ DATA IXDELD( 13)/ 26/ DATA ISTARD( 13)/ 143/ DATA NUMCOO( 13)/ 4/ C C DEFINE CHARACTER 2233--+- (PLUS OR MINUS) C DATA IOPERA( 147),IX( 147),IY( 147)/'MOVE', 0, 8/ DATA IOPERA( 148),IX( 148),IY( 148)/'DRAW', 0, -9/ DATA IOPERA( 149),IX( 149),IY( 149)/'MOVE', -8, 0/ DATA IOPERA( 150),IX( 150),IY( 150)/'DRAW', 8, 0/ DATA IOPERA( 151),IX( 151),IY( 151)/'MOVE', -8, -9/ DATA IOPERA( 152),IX( 152),IY( 152)/'DRAW', 8, -9/ C DATA IXMIND( 14)/ -12/ DATA IXMAXD( 14)/ 12/ DATA IXDELD( 14)/ 24/ DATA ISTARD( 14)/ 147/ DATA NUMCOO( 14)/ 6/ C C DEFINE CHARACTER 2234---+ (MINUS OR PLUS) C DATA IOPERA( 153),IX( 153),IY( 153)/'MOVE', 0, 8/ DATA IOPERA( 154),IX( 154),IY( 154)/'DRAW', 0, -9/ DATA IOPERA( 155),IX( 155),IY( 155)/'MOVE', -8, 8/ DATA IOPERA( 156),IX( 156),IY( 156)/'DRAW', 8, 8/ DATA IOPERA( 157),IX( 157),IY( 157)/'MOVE', -8, 0/ DATA IOPERA( 158),IX( 158),IY( 158)/'DRAW', 8, 0/ C DATA IXMIND( 15)/ -12/ DATA IXMAXD( 15)/ 12/ DATA IXDELD( 15)/ 24/ DATA ISTARD( 15)/ 153/ DATA NUMCOO( 15)/ 6/ C C DEFINE CHARACTER 2235--TIMES (TIMES SIGN) C DATA IOPERA( 159),IX( 159),IY( 159)/'MOVE', -7, 7/ DATA IOPERA( 160),IX( 160),IY( 160)/'DRAW', 7, -7/ DATA IOPERA( 161),IX( 161),IY( 161)/'MOVE', 7, 7/ DATA IOPERA( 162),IX( 162),IY( 162)/'DRAW', -7, -7/ C DATA IXMIND( 16)/ -11/ DATA IXMAXD( 16)/ 11/ DATA IXDELD( 16)/ 22/ DATA ISTARD( 16)/ 159/ DATA NUMCOO( 16)/ 4/ C C DEFINE CHARACTER 2236--DOTP (DOT PRODUCT SIGN) C DATA IOPERA( 163),IX( 163),IY( 163)/'MOVE', 0, 1/ DATA IOPERA( 164),IX( 164),IY( 164)/'DRAW', -1, 0/ DATA IOPERA( 165),IX( 165),IY( 165)/'DRAW', 0, -1/ DATA IOPERA( 166),IX( 166),IY( 166)/'DRAW', 1, 0/ DATA IOPERA( 167),IX( 167),IY( 167)/'DRAW', 0, 1/ C DATA IXMIND( 17)/ -5/ DATA IXMAXD( 17)/ 5/ DATA IXDELD( 17)/ 10/ DATA ISTARD( 17)/ 163/ DATA NUMCOO( 17)/ 5/ C C DEFINE CHARACTER 2237--DIVISION (DIVISION SIGN) C DATA IOPERA( 168),IX( 168),IY( 168)/'MOVE', 0, 9/ DATA IOPERA( 169),IX( 169),IY( 169)/'DRAW', -1, 8/ DATA IOPERA( 170),IX( 170),IY( 170)/'DRAW', 0, 7/ DATA IOPERA( 171),IX( 171),IY( 171)/'DRAW', 1, 8/ DATA IOPERA( 172),IX( 172),IY( 172)/'DRAW', 0, 9/ DATA IOPERA( 173),IX( 173),IY( 173)/'MOVE', -9, 0/ DATA IOPERA( 174),IX( 174),IY( 174)/'DRAW', 9, 0/ DATA IOPERA( 175),IX( 175),IY( 175)/'MOVE', 0, -7/ DATA IOPERA( 176),IX( 176),IY( 176)/'DRAW', -1, -8/ DATA IOPERA( 177),IX( 177),IY( 177)/'DRAW', 0, -9/ DATA IOPERA( 178),IX( 178),IY( 178)/'DRAW', 1, -8/ DATA IOPERA( 179),IX( 179),IY( 179)/'DRAW', 0, -7/ C DATA IXMIND( 18)/ -13/ DATA IXMAXD( 18)/ 13/ DATA IXDELD( 18)/ 26/ DATA ISTARD( 18)/ 168/ DATA NUMCOO( 18)/ 12/ C C DEFINE CHARACTER 2238--= (EQUAL SIGN) C DATA IOPERA( 180),IX( 180),IY( 180)/'MOVE', -9, 3/ DATA IOPERA( 181),IX( 181),IY( 181)/'DRAW', 9, 3/ DATA IOPERA( 182),IX( 182),IY( 182)/'MOVE', -9, -3/ DATA IOPERA( 183),IX( 183),IY( 183)/'DRAW', 9, -3/ C DATA IXMIND( 19)/ -13/ DATA IXMAXD( 19)/ 13/ DATA IXDELD( 19)/ 26/ DATA ISTARD( 19)/ 180/ DATA NUMCOO( 19)/ 4/ C C DEFINE CHARACTER 2239--NOTEQ (NOT EQUAL SIGN) C DATA IOPERA( 184),IX( 184),IY( 184)/'MOVE', 7, 9/ DATA IOPERA( 185),IX( 185),IY( 185)/'DRAW', -7, -9/ DATA IOPERA( 186),IX( 186),IY( 186)/'MOVE', -9, 3/ DATA IOPERA( 187),IX( 187),IY( 187)/'DRAW', 9, 3/ DATA IOPERA( 188),IX( 188),IY( 188)/'MOVE', -9, -3/ DATA IOPERA( 189),IX( 189),IY( 189)/'DRAW', 9, -3/ C DATA IXMIND( 20)/ -13/ DATA IXMAXD( 20)/ 13/ DATA IXDELD( 20)/ 26/ DATA ISTARD( 20)/ 184/ DATA NUMCOO( 20)/ 6/ C C DEFINE CHARACTER 2240--EQUIVALE (EQUIVALENCE SIGN) C DATA IOPERA( 190),IX( 190),IY( 190)/'MOVE', -9, 5/ DATA IOPERA( 191),IX( 191),IY( 191)/'DRAW', 9, 5/ DATA IOPERA( 192),IX( 192),IY( 192)/'MOVE', -9, 0/ DATA IOPERA( 193),IX( 193),IY( 193)/'DRAW', 9, 0/ DATA IOPERA( 194),IX( 194),IY( 194)/'MOVE', -9, -5/ DATA IOPERA( 195),IX( 195),IY( 195)/'DRAW', 9, -5/ C DATA IXMIND( 21)/ -13/ DATA IXMAXD( 21)/ 13/ DATA IXDELD( 21)/ 26/ DATA ISTARD( 21)/ 190/ DATA NUMCOO( 21)/ 6/ C C DEFINE CHARACTER 2241--< (LESS THAN SIGN) C DATA IOPERA( 196),IX( 196),IY( 196)/'MOVE', 8, 9/ DATA IOPERA( 197),IX( 197),IY( 197)/'DRAW', -8, 0/ DATA IOPERA( 198),IX( 198),IY( 198)/'DRAW', 8, -9/ C DATA IXMIND( 22)/ -12/ DATA IXMAXD( 22)/ 12/ DATA IXDELD( 22)/ 24/ DATA ISTARD( 22)/ 196/ DATA NUMCOO( 22)/ 3/ C C DEFINE CHARACTER 2242--> (GREATER THAN SIGN) C DATA IOPERA( 199),IX( 199),IY( 199)/'MOVE', -8, 9/ DATA IOPERA( 200),IX( 200),IY( 200)/'DRAW', 8, 0/ DATA IOPERA( 201),IX( 201),IY( 201)/'DRAW', -8, -9/ C DATA IXMIND( 23)/ -12/ DATA IXMAXD( 23)/ 12/ DATA IXDELD( 23)/ 24/ DATA ISTARD( 23)/ 199/ DATA NUMCOO( 23)/ 3/ C C DEFINE CHARACTER 2243--LTEQ (LESS THAN OR EQUAL TO SIGN) C DATA IOPERA( 202),IX( 202),IY( 202)/'MOVE', 8, 12/ DATA IOPERA( 203),IX( 203),IY( 203)/'DRAW', -8, 5/ DATA IOPERA( 204),IX( 204),IY( 204)/'DRAW', 8, -2/ DATA IOPERA( 205),IX( 205),IY( 205)/'MOVE', -8, -4/ DATA IOPERA( 206),IX( 206),IY( 206)/'DRAW', 8, -4/ DATA IOPERA( 207),IX( 207),IY( 207)/'MOVE', -8, -9/ DATA IOPERA( 208),IX( 208),IY( 208)/'DRAW', 8, -9/ C DATA IXMIND( 24)/ -12/ DATA IXMAXD( 24)/ 12/ DATA IXDELD( 24)/ 24/ DATA ISTARD( 24)/ 202/ DATA NUMCOO( 24)/ 7/ C C DEFINE CHARACTER 2244--GTEQ (GREATER THAN OR EQUAL TO SIGN) C DATA IOPERA( 209),IX( 209),IY( 209)/'MOVE', -8, 12/ DATA IOPERA( 210),IX( 210),IY( 210)/'DRAW', 8, 5/ DATA IOPERA( 211),IX( 211),IY( 211)/'DRAW', -8, -2/ DATA IOPERA( 212),IX( 212),IY( 212)/'MOVE', -8, -4/ DATA IOPERA( 213),IX( 213),IY( 213)/'DRAW', 8, -4/ DATA IOPERA( 214),IX( 214),IY( 214)/'MOVE', -8, -9/ DATA IOPERA( 215),IX( 215),IY( 215)/'DRAW', 8, -9/ C DATA IXMIND( 25)/ -12/ DATA IXMAXD( 25)/ 12/ DATA IXDELD( 25)/ 24/ DATA ISTARD( 25)/ 209/ DATA NUMCOO( 25)/ 7/ C C DEFINE CHARACTER 2245--VARIES (VARIES SIGN) C DATA IOPERA( 216),IX( 216),IY( 216)/'MOVE', 9, -5/ DATA IOPERA( 217),IX( 217),IY( 217)/'DRAW', 7, -5/ DATA IOPERA( 218),IX( 218),IY( 218)/'DRAW', 5, -4/ DATA IOPERA( 219),IX( 219),IY( 219)/'DRAW', 3, -2/ DATA IOPERA( 220),IX( 220),IY( 220)/'DRAW', 0, 2/ DATA IOPERA( 221),IX( 221),IY( 221)/'DRAW', -1, 3/ DATA IOPERA( 222),IX( 222),IY( 222)/'DRAW', -3, 4/ DATA IOPERA( 223),IX( 223),IY( 223)/'DRAW', -5, 4/ DATA IOPERA( 224),IX( 224),IY( 224)/'DRAW', -7, 3/ DATA IOPERA( 225),IX( 225),IY( 225)/'DRAW', -8, 1/ DATA IOPERA( 226),IX( 226),IY( 226)/'DRAW', -8, -1/ DATA IOPERA( 227),IX( 227),IY( 227)/'DRAW', -7, -3/ DATA IOPERA( 228),IX( 228),IY( 228)/'DRAW', -5, -4/ DATA IOPERA( 229),IX( 229),IY( 229)/'DRAW', -3, -4/ DATA IOPERA( 230),IX( 230),IY( 230)/'DRAW', -1, -3/ DATA IOPERA( 231),IX( 231),IY( 231)/'DRAW', 0, -2/ DATA IOPERA( 232),IX( 232),IY( 232)/'DRAW', 3, 2/ DATA IOPERA( 233),IX( 233),IY( 233)/'DRAW', 5, 4/ DATA IOPERA( 234),IX( 234),IY( 234)/'DRAW', 7, 5/ DATA IOPERA( 235),IX( 235),IY( 235)/'DRAW', 9, 5/ C DATA IXMIND( 26)/ -12/ DATA IXMAXD( 26)/ 13/ DATA IXDELD( 26)/ 25/ DATA ISTARD( 26)/ 216/ DATA NUMCOO( 26)/ 20/ C C DEFINE CHARACTER 2246--APPROX (APPROXIMATION SIGN) C DATA IOPERA( 236),IX( 236),IY( 236)/'MOVE', -9, -3/ DATA IOPERA( 237),IX( 237),IY( 237)/'DRAW', -9, -1/ DATA IOPERA( 238),IX( 238),IY( 238)/'DRAW', -8, 2/ DATA IOPERA( 239),IX( 239),IY( 239)/'DRAW', -6, 3/ DATA IOPERA( 240),IX( 240),IY( 240)/'DRAW', -4, 3/ DATA IOPERA( 241),IX( 241),IY( 241)/'DRAW', -2, 2/ DATA IOPERA( 242),IX( 242),IY( 242)/'DRAW', 2, -1/ DATA IOPERA( 243),IX( 243),IY( 243)/'DRAW', 4, -2/ DATA IOPERA( 244),IX( 244),IY( 244)/'DRAW', 6, -2/ DATA IOPERA( 245),IX( 245),IY( 245)/'DRAW', 8, -1/ DATA IOPERA( 246),IX( 246),IY( 246)/'DRAW', 9, 1/ DATA IOPERA( 247),IX( 247),IY( 247)/'MOVE', -9, -1/ DATA IOPERA( 248),IX( 248),IY( 248)/'DRAW', -8, 1/ DATA IOPERA( 249),IX( 249),IY( 249)/'DRAW', -6, 2/ DATA IOPERA( 250),IX( 250),IY( 250)/'DRAW', -4, 2/ DATA IOPERA( 251),IX( 251),IY( 251)/'DRAW', -2, 1/ DATA IOPERA( 252),IX( 252),IY( 252)/'DRAW', 2, -2/ DATA IOPERA( 253),IX( 253),IY( 253)/'DRAW', 4, -3/ DATA IOPERA( 254),IX( 254),IY( 254)/'DRAW', 6, -3/ DATA IOPERA( 255),IX( 255),IY( 255)/'DRAW', 8, -2/ DATA IOPERA( 256),IX( 256),IY( 256)/'DRAW', 9, 1/ DATA IOPERA( 257),IX( 257),IY( 257)/'DRAW', 9, 3/ C DATA IXMIND( 27)/ -12/ DATA IXMAXD( 27)/ 12/ DATA IXDELD( 27)/ 24/ DATA ISTARD( 27)/ 236/ DATA NUMCOO( 27)/ 22/ C C DEFINE CHARACTER 2247--CARAT (CARAT) C DATA IOPERA( 258),IX( 258),IY( 258)/'MOVE', -8, -2/ DATA IOPERA( 259),IX( 259),IY( 259)/'DRAW', 0, 3/ DATA IOPERA( 260),IX( 260),IY( 260)/'DRAW', 8, -2/ DATA IOPERA( 261),IX( 261),IY( 261)/'MOVE', -8, -2/ DATA IOPERA( 262),IX( 262),IY( 262)/'DRAW', 0, 2/ DATA IOPERA( 263),IX( 263),IY( 263)/'DRAW', 8, -2/ C DATA IXMIND( 28)/ -11/ DATA IXMAXD( 28)/ 11/ DATA IXDELD( 28)/ 22/ DATA ISTARD( 28)/ 258/ DATA NUMCOO( 28)/ 6/ C C DEFINE CHARACTER 2248--PRIME (PRIME = RIGHT ACCENT) C DATA IOPERA( 264),IX( 264),IY( 264)/'MOVE', 2, 12/ DATA IOPERA( 265),IX( 265),IY( 265)/'DRAW', -3, 6/ DATA IOPERA( 266),IX( 266),IY( 266)/'MOVE', 2, 12/ DATA IOPERA( 267),IX( 267),IY( 267)/'DRAW', 3, 11/ DATA IOPERA( 268),IX( 268),IY( 268)/'DRAW', -3, 6/ C DATA IXMIND( 29)/ -6/ DATA IXMAXD( 29)/ 6/ DATA IXDELD( 29)/ 12/ DATA ISTARD( 29)/ 264/ DATA NUMCOO( 29)/ 5/ C C DEFINE CHARACTER 2249--LACCENT (LEFT ACCENT) C DATA IOPERA( 269),IX( 269),IY( 269)/'MOVE', -2, 12/ DATA IOPERA( 270),IX( 270),IY( 270)/'DRAW', 3, 6/ DATA IOPERA( 271),IX( 271),IY( 271)/'MOVE', -2, 12/ DATA IOPERA( 272),IX( 272),IY( 272)/'DRAW', -3, 11/ DATA IOPERA( 273),IX( 273),IY( 273)/'DRAW', 3, 6/ C DATA IXMIND( 30)/ -6/ DATA IXMAXD( 30)/ 6/ DATA IXDELD( 30)/ 12/ DATA ISTARD( 30)/ 269/ DATA NUMCOO( 30)/ 5/ C C DEFINE CHARACTER 2250--BREVE (BREVE) C DATA IOPERA( 274),IX( 274),IY( 274)/'MOVE', -7, 12/ DATA IOPERA( 275),IX( 275),IY( 275)/'DRAW', -6, 10/ DATA IOPERA( 276),IX( 276),IY( 276)/'DRAW', -4, 8/ DATA IOPERA( 277),IX( 277),IY( 277)/'DRAW', -1, 7/ DATA IOPERA( 278),IX( 278),IY( 278)/'DRAW', 1, 7/ DATA IOPERA( 279),IX( 279),IY( 279)/'DRAW', 4, 8/ DATA IOPERA( 280),IX( 280),IY( 280)/'DRAW', 6, 10/ DATA IOPERA( 281),IX( 281),IY( 281)/'DRAW', 7, 12/ DATA IOPERA( 282),IX( 282),IY( 282)/'MOVE', -7, 12/ DATA IOPERA( 283),IX( 283),IY( 283)/'DRAW', -6, 9/ DATA IOPERA( 284),IX( 284),IY( 284)/'DRAW', -4, 7/ DATA IOPERA( 285),IX( 285),IY( 285)/'DRAW', -1, 6/ DATA IOPERA( 286),IX( 286),IY( 286)/'DRAW', 1, 6/ DATA IOPERA( 287),IX( 287),IY( 287)/'DRAW', 4, 7/ DATA IOPERA( 288),IX( 288),IY( 288)/'DRAW', 6, 9/ DATA IOPERA( 289),IX( 289),IY( 289)/'DRAW', 7, 12/ C DATA IXMIND( 31)/ -10/ DATA IXMAXD( 31)/ 10/ DATA IXDELD( 31)/ 20/ DATA ISTARD( 31)/ 274/ DATA NUMCOO( 31)/ 16/ C C DEFINE CHARACTER 2251--RQUOTE (RIGHT QUOTE) C DATA IOPERA( 290),IX( 290),IY( 290)/'MOVE', 0, 10/ DATA IOPERA( 291),IX( 291),IY( 291)/'DRAW', -1, 11/ DATA IOPERA( 292),IX( 292),IY( 292)/'DRAW', 0, 12/ DATA IOPERA( 293),IX( 293),IY( 293)/'DRAW', 1, 11/ DATA IOPERA( 294),IX( 294),IY( 294)/'DRAW', 1, 9/ DATA IOPERA( 295),IX( 295),IY( 295)/'DRAW', 0, 7/ DATA IOPERA( 296),IX( 296),IY( 296)/'DRAW', -1, 6/ C DATA IXMIND( 32)/ -5/ DATA IXMAXD( 32)/ 5/ DATA IXDELD( 32)/ 10/ DATA ISTARD( 32)/ 290/ DATA NUMCOO( 32)/ 7/ 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(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'MATH')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DMATH1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHARN 52 FORMAT('ICHARN = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGG4,ISUBG4,IFOUND,IERROR 59 FORMAT('IBUGG4,ISUBG4,IFOUND,IERROR = ',A4,2X,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 C ********************************************* C ** STEP 3-- ** C ** ADJUST THE COORDINATES IF A CIRCLE. ** C ** IF THE CHARACTER IS A CIRCLE ** C ** THEN SCALE THE FIGURE DOWN FROM ** C ** -17 TO 17 TO THE MORE USUAL -7 TO 7. ** C ** THE ORIGINAL CIRCLE WAS FROM -17 TO 17 ** C ** RATHER THAN -7 TO 7 IN ** C ** ORDER TO INCREASE THE RESOLUTION ** C ** AND GIVE A 32 POINT CIRCLE RATHER ** C ** THAN A 16 POINT CIRCLE. ** C ********************************************* C IF(ICHARN.EQ.102)GOTO1210 GOTO1290 C 1210 CONTINUE AFACTO=7.0/17.0 DO1220J=1,NUMCO X(J)=X(J)*AFACTO Y(J)=Y(J)*AFACTO 1220 CONTINUE IXMINS=(-7) IXMAXS=7 IXDELS=14 C 1290 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'MATH')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DMATH1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGG4,ISUBG4,IFOUND,IERROR 9012 FORMAT('IBUGG4,ISUBG4,IFOUND,IERROR = ',A4,2X,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 DMATH2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES C FOR MATH SYMBOLS (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-921-3651 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(150) DIMENSION IXMAXD(150) DIMENSION IXDELD(150) DIMENSION ISTARD(150) DIMENSION NUMCOO(150) C C-----COMMON---------------------------------------------------------- C 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-----DATA STATEMENTS------------------------------------------------- C DEFINE CHARACTER 2252--LQUOTE (LEFT QUOTE) C DATA IOPERA( 1),IX( 1),IY( 1)/'MOVE', 1, 12/ DATA IOPERA( 2),IX( 2),IY( 2)/'DRAW', 0, 11/ DATA IOPERA( 3),IX( 3),IY( 3)/'DRAW', -1, 9/ DATA IOPERA( 4),IX( 4),IY( 4)/'DRAW', -1, 7/ DATA IOPERA( 5),IX( 5),IY( 5)/'DRAW', 0, 6/ DATA IOPERA( 6),IX( 6),IY( 6)/'DRAW', 1, 7/ DATA IOPERA( 7),IX( 7),IY( 7)/'DRAW', 0, 8/ C DATA IXMIND( 33)/ -5/ DATA IXMAXD( 33)/ 5/ DATA IXDELD( 33)/ 10/ DATA ISTARD( 33)/ 1/ DATA NUMCOO( 33)/ 7/ C C DEFINE CHARACTER 2253--NASPIRAT (NORMAL ASPIRATE) C DATA IOPERA( 8),IX( 8),IY( 8)/'MOVE', 0, 10/ DATA IOPERA( 9),IX( 9),IY( 9)/'DRAW', 1, 11/ DATA IOPERA( 10),IX( 10),IY( 10)/'DRAW', 0, 12/ DATA IOPERA( 11),IX( 11),IY( 11)/'DRAW', -1, 11/ DATA IOPERA( 12),IX( 12),IY( 12)/'DRAW', -1, 9/ DATA IOPERA( 13),IX( 13),IY( 13)/'DRAW', 0, 7/ DATA IOPERA( 14),IX( 14),IY( 14)/'DRAW', 1, 6/ C DATA IXMIND( 34)/ -5/ DATA IXMAXD( 34)/ 5/ DATA IXDELD( 34)/ 10/ DATA ISTARD( 34)/ 8/ DATA NUMCOO( 34)/ 7/ C C DEFINE CHARACTER 2254--IASPIRAT (INVERTED ASPIRATE) C DATA IOPERA( 15),IX( 15),IY( 15)/'MOVE', -1, 12/ DATA IOPERA( 16),IX( 16),IY( 16)/'DRAW', 0, 11/ DATA IOPERA( 17),IX( 17),IY( 17)/'DRAW', 1, 9/ DATA IOPERA( 18),IX( 18),IY( 18)/'DRAW', 1, 7/ DATA IOPERA( 19),IX( 19),IY( 19)/'DRAW', 0, 6/ DATA IOPERA( 20),IX( 20),IY( 20)/'DRAW', -1, 7/ DATA IOPERA( 21),IX( 21),IY( 21)/'DRAW', 0, 8/ C DATA IXMIND( 35)/ -5/ DATA IXMAXD( 35)/ 5/ DATA IXDELD( 35)/ 10/ DATA ISTARD( 35)/ 15/ DATA NUMCOO( 35)/ 7/ C C DEFINE CHARACTER 2255--RADICAL (RADICAL) C DATA IOPERA( 22),IX( 22),IY( 22)/'MOVE', -10, 5/ DATA IOPERA( 23),IX( 23),IY( 23)/'DRAW', -6, 5/ DATA IOPERA( 24),IX( 24),IY( 24)/'DRAW', 0, -7/ DATA IOPERA( 25),IX( 25),IY( 25)/'MOVE', -7, 5/ DATA IOPERA( 26),IX( 26),IY( 26)/'DRAW', 0, -9/ DATA IOPERA( 27),IX( 27),IY( 27)/'MOVE', 9, 16/ DATA IOPERA( 28),IX( 28),IY( 28)/'DRAW', 0, -9/ C DATA IXMIND( 36)/ -13/ DATA IXMAXD( 36)/ 9/ DATA IXDELD( 36)/ 22/ DATA ISTARD( 36)/ 22/ DATA NUMCOO( 36)/ 7/ C C DEFINE CHARACTER 2256--SUBSET (SUBSET SYMBOL) C DATA IOPERA( 29),IX( 29),IY( 29)/'MOVE', 8, 8/ DATA IOPERA( 30),IX( 30),IY( 30)/'DRAW', 1, 8/ DATA IOPERA( 31),IX( 31),IY( 31)/'DRAW', -3, 7/ DATA IOPERA( 32),IX( 32),IY( 32)/'DRAW', -5, 6/ DATA IOPERA( 33),IX( 33),IY( 33)/'DRAW', -7, 4/ DATA IOPERA( 34),IX( 34),IY( 34)/'DRAW', -8, 1/ DATA IOPERA( 35),IX( 35),IY( 35)/'DRAW', -8, -1/ DATA IOPERA( 36),IX( 36),IY( 36)/'DRAW', -7, -4/ DATA IOPERA( 37),IX( 37),IY( 37)/'DRAW', -5, -6/ DATA IOPERA( 38),IX( 38),IY( 38)/'DRAW', -3, -7/ DATA IOPERA( 39),IX( 39),IY( 39)/'DRAW', 1, -8/ DATA IOPERA( 40),IX( 40),IY( 40)/'DRAW', 8, -8/ C DATA IXMIND( 37)/ -12/ DATA IXMAXD( 37)/ 12/ DATA IXDELD( 37)/ 24/ DATA ISTARD( 37)/ 29/ DATA NUMCOO( 37)/ 12/ C C DEFINE CHARACTER 2257--UNION (UNION SYMBOL) C DATA IOPERA( 41),IX( 41),IY( 41)/'MOVE', -8, 8/ DATA IOPERA( 42),IX( 42),IY( 42)/'DRAW', -8, 1/ DATA IOPERA( 43),IX( 43),IY( 43)/'DRAW', -7, -3/ DATA IOPERA( 44),IX( 44),IY( 44)/'DRAW', -6, -5/ DATA IOPERA( 45),IX( 45),IY( 45)/'DRAW', -4, -7/ DATA IOPERA( 46),IX( 46),IY( 46)/'DRAW', -1, -8/ DATA IOPERA( 47),IX( 47),IY( 47)/'DRAW', 1, -8/ DATA IOPERA( 48),IX( 48),IY( 48)/'DRAW', 4, -7/ DATA IOPERA( 49),IX( 49),IY( 49)/'DRAW', 6, -5/ DATA IOPERA( 50),IX( 50),IY( 50)/'DRAW', 7, -3/ DATA IOPERA( 51),IX( 51),IY( 51)/'DRAW', 8, 1/ DATA IOPERA( 52),IX( 52),IY( 52)/'DRAW', 8, 8/ C DATA IXMIND( 38)/ -12/ DATA IXMAXD( 38)/ 12/ DATA IXDELD( 38)/ 24/ DATA ISTARD( 38)/ 41/ DATA NUMCOO( 38)/ 12/ C C DEFINE CHARACTER 2258--SUPERSET (SUPERSET SYMBOL) C DATA IOPERA( 53),IX( 53),IY( 53)/'MOVE', -8, 8/ DATA IOPERA( 54),IX( 54),IY( 54)/'DRAW', -1, 8/ DATA IOPERA( 55),IX( 55),IY( 55)/'DRAW', 3, 7/ DATA IOPERA( 56),IX( 56),IY( 56)/'DRAW', 5, 6/ DATA IOPERA( 57),IX( 57),IY( 57)/'DRAW', 7, 4/ DATA IOPERA( 58),IX( 58),IY( 58)/'DRAW', 8, 1/ DATA IOPERA( 59),IX( 59),IY( 59)/'DRAW', 8, -1/ DATA IOPERA( 60),IX( 60),IY( 60)/'DRAW', 7, -4/ DATA IOPERA( 61),IX( 61),IY( 61)/'DRAW', 5, -6/ DATA IOPERA( 62),IX( 62),IY( 62)/'DRAW', 3, -7/ DATA IOPERA( 63),IX( 63),IY( 63)/'DRAW', -1, -8/ DATA IOPERA( 64),IX( 64),IY( 64)/'DRAW', -8, -8/ C DATA IXMIND( 39)/ -12/ DATA IXMAXD( 39)/ 12/ DATA IXDELD( 39)/ 24/ DATA ISTARD( 39)/ 53/ DATA NUMCOO( 39)/ 12/ C C DEFINE CHARACTER 2259--INTERSEC (INTERSECTION SYMBOL) C DATA IOPERA( 65),IX( 65),IY( 65)/'MOVE', -8, -8/ DATA IOPERA( 66),IX( 66),IY( 66)/'DRAW', -8, -1/ DATA IOPERA( 67),IX( 67),IY( 67)/'DRAW', -7, 3/ DATA IOPERA( 68),IX( 68),IY( 68)/'DRAW', -6, 5/ DATA IOPERA( 69),IX( 69),IY( 69)/'DRAW', -4, 7/ DATA IOPERA( 70),IX( 70),IY( 70)/'DRAW', -1, 8/ DATA IOPERA( 71),IX( 71),IY( 71)/'DRAW', 1, 8/ DATA IOPERA( 72),IX( 72),IY( 72)/'DRAW', 4, 7/ DATA IOPERA( 73),IX( 73),IY( 73)/'DRAW', 6, 5/ DATA IOPERA( 74),IX( 74),IY( 74)/'DRAW', 7, 3/ DATA IOPERA( 75),IX( 75),IY( 75)/'DRAW', 8, -1/ DATA IOPERA( 76),IX( 76),IY( 76)/'DRAW', 8, -8/ C DATA IXMIND( 40)/ -12/ DATA IXMAXD( 40)/ 12/ DATA IXDELD( 40)/ 24/ DATA ISTARD( 40)/ 65/ DATA NUMCOO( 40)/ 12/ C C DEFINE CHARACTER 2260--ELEMENT (ELEMENT SYMBOL) C DATA IOPERA( 77),IX( 77),IY( 77)/'MOVE', 8, 8/ DATA IOPERA( 78),IX( 78),IY( 78)/'DRAW', 1, 8/ DATA IOPERA( 79),IX( 79),IY( 79)/'DRAW', -3, 7/ DATA IOPERA( 80),IX( 80),IY( 80)/'DRAW', -5, 6/ DATA IOPERA( 81),IX( 81),IY( 81)/'DRAW', -7, 4/ DATA IOPERA( 82),IX( 82),IY( 82)/'DRAW', -8, 1/ DATA IOPERA( 83),IX( 83),IY( 83)/'DRAW', -8, -1/ DATA IOPERA( 84),IX( 84),IY( 84)/'DRAW', -7, -4/ DATA IOPERA( 85),IX( 85),IY( 85)/'DRAW', -5, -6/ DATA IOPERA( 86),IX( 86),IY( 86)/'DRAW', -3, -7/ DATA IOPERA( 87),IX( 87),IY( 87)/'DRAW', 1, -8/ DATA IOPERA( 88),IX( 88),IY( 88)/'DRAW', 8, -8/ DATA IOPERA( 89),IX( 89),IY( 89)/'MOVE', -8, 0/ DATA IOPERA( 90),IX( 90),IY( 90)/'DRAW', 4, 0/ C DATA IXMIND( 41)/ -12/ DATA IXMAXD( 41)/ 12/ DATA IXDELD( 41)/ 24/ DATA ISTARD( 41)/ 77/ DATA NUMCOO( 41)/ 14/ C C DEFINE CHARACTER 2261--RARROW (RIGHT ARROW) C DATA IOPERA( 91),IX( 91),IY( 91)/'MOVE', 6, 2/ DATA IOPERA( 92),IX( 92),IY( 92)/'DRAW', 9, 0/ DATA IOPERA( 93),IX( 93),IY( 93)/'DRAW', 6, -2/ DATA IOPERA( 94),IX( 94),IY( 94)/'MOVE', 3, 5/ DATA IOPERA( 95),IX( 95),IY( 95)/'DRAW', 8, 0/ DATA IOPERA( 96),IX( 96),IY( 96)/'DRAW', 3, -5/ DATA IOPERA( 97),IX( 97),IY( 97)/'MOVE', -9, 0/ DATA IOPERA( 98),IX( 98),IY( 98)/'DRAW', 8, 0/ C DATA IXMIND( 42)/ -13/ DATA IXMAXD( 42)/ 13/ DATA IXDELD( 42)/ 26/ DATA ISTARD( 42)/ 91/ DATA NUMCOO( 42)/ 8/ C C DEFINE CHARACTER 2262--UARROW (UP ARROW) C DATA IOPERA( 99),IX( 99),IY( 99)/'MOVE', -2, 6/ DATA IOPERA( 100),IX( 100),IY( 100)/'DRAW', 0, 9/ DATA IOPERA( 101),IX( 101),IY( 101)/'DRAW', 2, 6/ DATA IOPERA( 102),IX( 102),IY( 102)/'MOVE', -5, 3/ DATA IOPERA( 103),IX( 103),IY( 103)/'DRAW', 0, 8/ DATA IOPERA( 104),IX( 104),IY( 104)/'DRAW', 5, 3/ DATA IOPERA( 105),IX( 105),IY( 105)/'MOVE', 0, 8/ DATA IOPERA( 106),IX( 106),IY( 106)/'DRAW', 0, -9/ C DATA IXMIND( 43)/ -8/ DATA IXMAXD( 43)/ 8/ DATA IXDELD( 43)/ 16/ DATA ISTARD( 43)/ 99/ DATA NUMCOO( 43)/ 8/ C C DEFINE CHARACTER 2263--LARROW (LEFT ARROW) C DATA IOPERA( 107),IX( 107),IY( 107)/'MOVE', -6, 2/ DATA IOPERA( 108),IX( 108),IY( 108)/'DRAW', -9, 0/ DATA IOPERA( 109),IX( 109),IY( 109)/'DRAW', -6, -2/ DATA IOPERA( 110),IX( 110),IY( 110)/'MOVE', -3, 5/ DATA IOPERA( 111),IX( 111),IY( 111)/'DRAW', -8, 0/ DATA IOPERA( 112),IX( 112),IY( 112)/'DRAW', -3, -5/ DATA IOPERA( 113),IX( 113),IY( 113)/'MOVE', -8, 0/ DATA IOPERA( 114),IX( 114),IY( 114)/'DRAW', 9, 0/ C DATA IXMIND( 44)/ -13/ DATA IXMAXD( 44)/ 13/ DATA IXDELD( 44)/ 26/ DATA ISTARD( 44)/ 107/ DATA NUMCOO( 44)/ 8/ C C DEFINE CHARACTER 2264--DARROW (DOWN ARROW) C DATA IOPERA( 115),IX( 115),IY( 115)/'MOVE', -2, -6/ DATA IOPERA( 116),IX( 116),IY( 116)/'DRAW', 0, -9/ DATA IOPERA( 117),IX( 117),IY( 117)/'DRAW', 2, -6/ DATA IOPERA( 118),IX( 118),IY( 118)/'MOVE', -5, -3/ DATA IOPERA( 119),IX( 119),IY( 119)/'DRAW', 0, -8/ DATA IOPERA( 120),IX( 120),IY( 120)/'DRAW', 5, -3/ DATA IOPERA( 121),IX( 121),IY( 121)/'MOVE', 0, 9/ DATA IOPERA( 122),IX( 122),IY( 122)/'DRAW', 0, -8/ C DATA IXMIND( 45)/ -8/ DATA IXMAXD( 45)/ 8/ DATA IXDELD( 45)/ 16/ DATA ISTARD( 45)/ 115/ DATA NUMCOO( 45)/ 8/ C C DEFINE CHARACTER 2265--PARTIAL (PARTIAL DERIVATIVE = NABLA) C DATA IOPERA( 123),IX( 123),IY( 123)/'MOVE', 6, 0/ DATA IOPERA( 124),IX( 124),IY( 124)/'DRAW', 5, 3/ DATA IOPERA( 125),IX( 125),IY( 125)/'DRAW', 4, 4/ DATA IOPERA( 126),IX( 126),IY( 126)/'DRAW', 2, 5/ DATA IOPERA( 127),IX( 127),IY( 127)/'DRAW', 0, 5/ DATA IOPERA( 128),IX( 128),IY( 128)/'DRAW', -3, 4/ DATA IOPERA( 129),IX( 129),IY( 129)/'DRAW', -5, 1/ DATA IOPERA( 130),IX( 130),IY( 130)/'DRAW', -6, -2/ DATA IOPERA( 131),IX( 131),IY( 131)/'DRAW', -6, -5/ DATA IOPERA( 132),IX( 132),IY( 132)/'DRAW', -5, -7/ DATA IOPERA( 133),IX( 133),IY( 133)/'DRAW', -4, -8/ DATA IOPERA( 134),IX( 134),IY( 134)/'DRAW', -2, -9/ DATA IOPERA( 135),IX( 135),IY( 135)/'DRAW', 0, -9/ DATA IOPERA( 136),IX( 136),IY( 136)/'DRAW', 3, -8/ DATA IOPERA( 137),IX( 137),IY( 137)/'DRAW', 5, -6/ DATA IOPERA( 138),IX( 138),IY( 138)/'DRAW', 6, -3/ DATA IOPERA( 139),IX( 139),IY( 139)/'DRAW', 7, 2/ DATA IOPERA( 140),IX( 140),IY( 140)/'DRAW', 7, 7/ DATA IOPERA( 141),IX( 141),IY( 141)/'DRAW', 6, 10/ DATA IOPERA( 142),IX( 142),IY( 142)/'DRAW', 5, 11/ DATA IOPERA( 143),IX( 143),IY( 143)/'DRAW', 3, 12/ DATA IOPERA( 144),IX( 144),IY( 144)/'DRAW', 0, 12/ DATA IOPERA( 145),IX( 145),IY( 145)/'DRAW', -2, 11/ DATA IOPERA( 146),IX( 146),IY( 146)/'DRAW', -3, 10/ DATA IOPERA( 147),IX( 147),IY( 147)/'DRAW', -3, 9/ DATA IOPERA( 148),IX( 148),IY( 148)/'DRAW', -2, 9/ DATA IOPERA( 149),IX( 149),IY( 149)/'DRAW', -2, 10/ DATA IOPERA( 150),IX( 150),IY( 150)/'MOVE', 0, 5/ DATA IOPERA( 151),IX( 151),IY( 151)/'DRAW', -2, 4/ DATA IOPERA( 152),IX( 152),IY( 152)/'DRAW', -4, 1/ DATA IOPERA( 153),IX( 153),IY( 153)/'DRAW', -5, -2/ DATA IOPERA( 154),IX( 154),IY( 154)/'DRAW', -5, -6/ DATA IOPERA( 155),IX( 155),IY( 155)/'DRAW', -4, -8/ DATA IOPERA( 156),IX( 156),IY( 156)/'MOVE', 0, -9/ DATA IOPERA( 157),IX( 157),IY( 157)/'DRAW', 2, -8/ DATA IOPERA( 158),IX( 158),IY( 158)/'DRAW', 4, -6/ DATA IOPERA( 159),IX( 159),IY( 159)/'DRAW', 5, -3/ DATA IOPERA( 160),IX( 160),IY( 160)/'DRAW', 6, 2/ DATA IOPERA( 161),IX( 161),IY( 161)/'DRAW', 6, 7/ DATA IOPERA( 162),IX( 162),IY( 162)/'DRAW', 5, 10/ DATA IOPERA( 163),IX( 163),IY( 163)/'DRAW', 3, 12/ C DATA IXMIND( 46)/ -9/ DATA IXMAXD( 46)/ 10/ DATA IXDELD( 46)/ 19/ DATA ISTARD( 46)/ 123/ DATA NUMCOO( 46)/ 41/ C C DEFINE CHARACTER 2266--DEL (DELTA = VECTOR OPERATOR) C DATA IOPERA( 164),IX( 164),IY( 164)/'MOVE', -8, 12/ DATA IOPERA( 165),IX( 165),IY( 165)/'DRAW', 0, -9/ DATA IOPERA( 166),IX( 166),IY( 166)/'MOVE', -7, 12/ DATA IOPERA( 167),IX( 167),IY( 167)/'DRAW', 0, -7/ DATA IOPERA( 168),IX( 168),IY( 168)/'MOVE', 8, 12/ DATA IOPERA( 169),IX( 169),IY( 169)/'DRAW', 0, -9/ DATA IOPERA( 170),IX( 170),IY( 170)/'MOVE', -8, 12/ DATA IOPERA( 171),IX( 171),IY( 171)/'DRAW', 8, 12/ DATA IOPERA( 172),IX( 172),IY( 172)/'MOVE', -7, 11/ DATA IOPERA( 173),IX( 173),IY( 173)/'DRAW', 7, 11/ C DATA IXMIND( 47)/ -10/ DATA IXMAXD( 47)/ 10/ DATA IXDELD( 47)/ 20/ DATA ISTARD( 47)/ 164/ DATA NUMCOO( 47)/ 10/ C C DEFINE CHARACTER 2267--LRADICAL (LONGER RADICAL) C DATA IOPERA( 174),IX( 174),IY( 174)/'MOVE', -14, 5/ DATA IOPERA( 175),IX( 175),IY( 175)/'DRAW', -9, 5/ DATA IOPERA( 176),IX( 176),IY( 176)/'DRAW', 0, -7/ DATA IOPERA( 177),IX( 177),IY( 177)/'MOVE', -10, 4/ DATA IOPERA( 178),IX( 178),IY( 178)/'DRAW', 0, -9/ DATA IOPERA( 179),IX( 179),IY( 179)/'MOVE', 16, 24/ DATA IOPERA( 180),IX( 180),IY( 180)/'DRAW', 0, -9/ C DATA IXMIND( 48)/ -17/ DATA IXMAXD( 48)/ 16/ DATA IXDELD( 48)/ 33/ DATA ISTARD( 48)/ 174/ DATA NUMCOO( 48)/ 7/ C C DEFINE CHARACTER 2268--INTEGRAL (INTEGRAL) C DATA IOPERA( 181),IX( 181),IY( 181)/'MOVE', 9, 15/ DATA IOPERA( 182),IX( 182),IY( 182)/'DRAW', 8, 14/ DATA IOPERA( 183),IX( 183),IY( 183)/'DRAW', 9, 13/ DATA IOPERA( 184),IX( 184),IY( 184)/'DRAW', 10, 14/ DATA IOPERA( 185),IX( 185),IY( 185)/'DRAW', 10, 15/ DATA IOPERA( 186),IX( 186),IY( 186)/'DRAW', 9, 16/ DATA IOPERA( 187),IX( 187),IY( 187)/'DRAW', 7, 16/ DATA IOPERA( 188),IX( 188),IY( 188)/'DRAW', 5, 15/ DATA IOPERA( 189),IX( 189),IY( 189)/'DRAW', 3, 13/ DATA IOPERA( 190),IX( 190),IY( 190)/'DRAW', 2, 11/ DATA IOPERA( 191),IX( 191),IY( 191)/'DRAW', 1, 8/ DATA IOPERA( 192),IX( 192),IY( 192)/'DRAW', 0, 4/ DATA IOPERA( 193),IX( 193),IY( 193)/'DRAW', -2, -8/ DATA IOPERA( 194),IX( 194),IY( 194)/'DRAW', -3, -12/ DATA IOPERA( 195),IX( 195),IY( 195)/'DRAW', -4, -14/ DATA IOPERA( 196),IX( 196),IY( 196)/'MOVE', 4, 14/ DATA IOPERA( 197),IX( 197),IY( 197)/'DRAW', 3, 12/ DATA IOPERA( 198),IX( 198),IY( 198)/'DRAW', 2, 8/ DATA IOPERA( 199),IX( 199),IY( 199)/'DRAW', 0, -4/ DATA IOPERA( 200),IX( 200),IY( 200)/'DRAW', -1, -8/ DATA IOPERA( 201),IX( 201),IY( 201)/'DRAW', -2, -11/ DATA IOPERA( 202),IX( 202),IY( 202)/'DRAW', -3, -13/ DATA IOPERA( 203),IX( 203),IY( 203)/'DRAW', -5, -15/ DATA IOPERA( 204),IX( 204),IY( 204)/'DRAW', -7, -16/ DATA IOPERA( 205),IX( 205),IY( 205)/'DRAW', -9, -16/ DATA IOPERA( 206),IX( 206),IY( 206)/'DRAW', -10, -15/ DATA IOPERA( 207),IX( 207),IY( 207)/'DRAW', -10, -14/ DATA IOPERA( 208),IX( 208),IY( 208)/'DRAW', -9, -13/ DATA IOPERA( 209),IX( 209),IY( 209)/'DRAW', -8, -14/ DATA IOPERA( 210),IX( 210),IY( 210)/'DRAW', -9, -15/ C DATA IXMIND( 49)/ -12/ DATA IXMAXD( 49)/ 12/ DATA IXDELD( 49)/ 24/ DATA ISTARD( 49)/ 181/ DATA NUMCOO( 49)/ 30/ C C DEFINE CHARACTER 2269--CINTEGRA (CIRCULAR INTEGRAL) C DATA IOPERA( 211),IX( 211),IY( 211)/'MOVE', 9, 15/ DATA IOPERA( 212),IX( 212),IY( 212)/'DRAW', 8, 14/ DATA IOPERA( 213),IX( 213),IY( 213)/'DRAW', 9, 13/ DATA IOPERA( 214),IX( 214),IY( 214)/'DRAW', 10, 14/ DATA IOPERA( 215),IX( 215),IY( 215)/'DRAW', 10, 15/ DATA IOPERA( 216),IX( 216),IY( 216)/'DRAW', 9, 16/ DATA IOPERA( 217),IX( 217),IY( 217)/'DRAW', 7, 16/ DATA IOPERA( 218),IX( 218),IY( 218)/'DRAW', 5, 15/ DATA IOPERA( 219),IX( 219),IY( 219)/'DRAW', 3, 13/ DATA IOPERA( 220),IX( 220),IY( 220)/'DRAW', 2, 11/ DATA IOPERA( 221),IX( 221),IY( 221)/'DRAW', 1, 8/ DATA IOPERA( 222),IX( 222),IY( 222)/'DRAW', 0, 4/ DATA IOPERA( 223),IX( 223),IY( 223)/'DRAW', -2, -8/ DATA IOPERA( 224),IX( 224),IY( 224)/'DRAW', -3, -12/ DATA IOPERA( 225),IX( 225),IY( 225)/'DRAW', -4, -14/ DATA IOPERA( 226),IX( 226),IY( 226)/'MOVE', 4, 14/ DATA IOPERA( 227),IX( 227),IY( 227)/'DRAW', 3, 12/ DATA IOPERA( 228),IX( 228),IY( 228)/'DRAW', 2, 8/ DATA IOPERA( 229),IX( 229),IY( 229)/'DRAW', 0, -4/ DATA IOPERA( 230),IX( 230),IY( 230)/'DRAW', -1, -8/ DATA IOPERA( 231),IX( 231),IY( 231)/'DRAW', -2, -11/ DATA IOPERA( 232),IX( 232),IY( 232)/'DRAW', -3, -13/ DATA IOPERA( 233),IX( 233),IY( 233)/'DRAW', -5, -15/ DATA IOPERA( 234),IX( 234),IY( 234)/'DRAW', -7, -16/ DATA IOPERA( 235),IX( 235),IY( 235)/'DRAW', -9, -16/ DATA IOPERA( 236),IX( 236),IY( 236)/'DRAW', -10, -15/ DATA IOPERA( 237),IX( 237),IY( 237)/'DRAW', -10, -14/ DATA IOPERA( 238),IX( 238),IY( 238)/'DRAW', -9, -13/ DATA IOPERA( 239),IX( 239),IY( 239)/'DRAW', -8, -14/ DATA IOPERA( 240),IX( 240),IY( 240)/'DRAW', -9, -15/ DATA IOPERA( 241),IX( 241),IY( 241)/'MOVE', -1, 7/ DATA IOPERA( 242),IX( 242),IY( 242)/'DRAW', -4, 6/ DATA IOPERA( 243),IX( 243),IY( 243)/'DRAW', -6, 4/ DATA IOPERA( 244),IX( 244),IY( 244)/'DRAW', -7, 1/ DATA IOPERA( 245),IX( 245),IY( 245)/'DRAW', -7, -1/ DATA IOPERA( 246),IX( 246),IY( 246)/'DRAW', -6, -4/ DATA IOPERA( 247),IX( 247),IY( 247)/'DRAW', -4, -6/ DATA IOPERA( 248),IX( 248),IY( 248)/'DRAW', -1, -7/ DATA IOPERA( 249),IX( 249),IY( 249)/'DRAW', 1, -7/ DATA IOPERA( 250),IX( 250),IY( 250)/'DRAW', 4, -6/ DATA IOPERA( 251),IX( 251),IY( 251)/'DRAW', 6, -4/ DATA IOPERA( 252),IX( 252),IY( 252)/'DRAW', 7, -1/ DATA IOPERA( 253),IX( 253),IY( 253)/'DRAW', 7, 1/ DATA IOPERA( 254),IX( 254),IY( 254)/'DRAW', 6, 4/ DATA IOPERA( 255),IX( 255),IY( 255)/'DRAW', 4, 6/ DATA IOPERA( 256),IX( 256),IY( 256)/'DRAW', 1, 7/ DATA IOPERA( 257),IX( 257),IY( 257)/'DRAW', -1, 7/ C DATA IXMIND( 50)/ -12/ DATA IXMAXD( 50)/ 12/ DATA IXDELD( 50)/ 24/ DATA ISTARD( 50)/ 211/ DATA NUMCOO( 50)/ 47/ C C DEFINE CHARACTER 2270--INFINITY (INFINITY SIGN) C DATA IOPERA( 258),IX( 258),IY( 258)/'MOVE', 10, -1/ DATA IOPERA( 259),IX( 259),IY( 259)/'DRAW', 9, -3/ DATA IOPERA( 260),IX( 260),IY( 260)/'DRAW', 7, -4/ DATA IOPERA( 261),IX( 261),IY( 261)/'DRAW', 5, -4/ DATA IOPERA( 262),IX( 262),IY( 262)/'DRAW', 3, -3/ DATA IOPERA( 263),IX( 263),IY( 263)/'DRAW', 2, -2/ DATA IOPERA( 264),IX( 264),IY( 264)/'DRAW', -1, 2/ DATA IOPERA( 265),IX( 265),IY( 265)/'DRAW', -2, 3/ DATA IOPERA( 266),IX( 266),IY( 266)/'DRAW', -4, 4/ DATA IOPERA( 267),IX( 267),IY( 267)/'DRAW', -6, 4/ DATA IOPERA( 268),IX( 268),IY( 268)/'DRAW', -8, 3/ DATA IOPERA( 269),IX( 269),IY( 269)/'DRAW', -9, 1/ DATA IOPERA( 270),IX( 270),IY( 270)/'DRAW', -9, -1/ DATA IOPERA( 271),IX( 271),IY( 271)/'DRAW', -8, -3/ DATA IOPERA( 272),IX( 272),IY( 272)/'DRAW', -6, -4/ DATA IOPERA( 273),IX( 273),IY( 273)/'DRAW', -4, -4/ DATA IOPERA( 274),IX( 274),IY( 274)/'DRAW', -2, -3/ DATA IOPERA( 275),IX( 275),IY( 275)/'DRAW', -1, -2/ DATA IOPERA( 276),IX( 276),IY( 276)/'DRAW', 2, 2/ DATA IOPERA( 277),IX( 277),IY( 277)/'DRAW', 3, 3/ DATA IOPERA( 278),IX( 278),IY( 278)/'DRAW', 5, 4/ DATA IOPERA( 279),IX( 279),IY( 279)/'DRAW', 7, 4/ DATA IOPERA( 280),IX( 280),IY( 280)/'DRAW', 9, 3/ DATA IOPERA( 281),IX( 281),IY( 281)/'DRAW', 10, 1/ DATA IOPERA( 282),IX( 282),IY( 282)/'DRAW', 10, -1/ C DATA IXMIND( 51)/ -12/ DATA IXMAXD( 51)/ 13/ DATA IXDELD( 51)/ 25/ DATA ISTARD( 51)/ 258/ DATA NUMCOO( 51)/ 25/ 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(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'MATH')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DMATH2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHARN 52 FORMAT('ICHARN = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGG4,ISUBG4,IFOUND,IERROR 59 FORMAT('IBUGG4,ISUBG4,IFOUND,IERROR = ',A4,2X,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 C ********************************************* C ** STEP 3-- ** C ** ADJUST THE COORDINATES IF A CIRCLE. ** C ** IF THE CHARACTER IS A CIRCLE ** C ** THEN SCALE THE FIGURE DOWN FROM ** C ** -17 TO 17 TO THE MORE USUAL -7 TO 7. ** C ** THE ORIGINAL CIRCLE WAS FROM -17 TO 17 ** C ** RATHER THAN -7 TO 7 IN ** C ** ORDER TO INCREASE THE RESOLUTION ** C ** AND GIVE A 32 POINT CIRCLE RATHER ** C ** THAN A 16 POINT CIRCLE. ** C ********************************************* C IF(ICHARN.EQ.102)GOTO1210 GOTO1290 C 1210 CONTINUE AFACTO=7.0/17.0 DO1220J=1,NUMCO X(J)=X(J)*AFACTO Y(J)=Y(J)*AFACTO 1220 CONTINUE IXMINS=(-7) IXMAXS=7 IXDELS=14 C 1290 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'MATH')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DMATH2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGG4,ISUBG4,IFOUND,IERROR 9012 FORMAT('IBUGG4,ISUBG4,IFOUND,IERROR = ',A4,2X,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 DMATH3(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES C FOR MATH SYMBOLS (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-921-3651 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(150) DIMENSION IXMAXD(150) DIMENSION IXDELD(150) DIMENSION ISTARD(150) DIMENSION NUMCOO(150) C C-----COMMON---------------------------------------------------------- C 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-----DATA STATEMENTS------------------------------------------------- C DEFINE CHARACTER 2271--% (PERCENT SIGN) C DATA IOPERA( 1),IX( 1),IY( 1)/'MOVE', 9, 12/ DATA IOPERA( 2),IX( 2),IY( 2)/'DRAW', -9, -9/ DATA IOPERA( 3),IX( 3),IY( 3)/'MOVE', -4, 12/ DATA IOPERA( 4),IX( 4),IY( 4)/'DRAW', -2, 10/ DATA IOPERA( 5),IX( 5),IY( 5)/'DRAW', -2, 8/ DATA IOPERA( 6),IX( 6),IY( 6)/'DRAW', -3, 6/ DATA IOPERA( 7),IX( 7),IY( 7)/'DRAW', -5, 5/ DATA IOPERA( 8),IX( 8),IY( 8)/'DRAW', -7, 5/ DATA IOPERA( 9),IX( 9),IY( 9)/'DRAW', -9, 7/ DATA IOPERA( 10),IX( 10),IY( 10)/'DRAW', -9, 9/ DATA IOPERA( 11),IX( 11),IY( 11)/'DRAW', -8, 11/ DATA IOPERA( 12),IX( 12),IY( 12)/'DRAW', -6, 12/ DATA IOPERA( 13),IX( 13),IY( 13)/'DRAW', -4, 12/ DATA IOPERA( 14),IX( 14),IY( 14)/'DRAW', -2, 11/ DATA IOPERA( 15),IX( 15),IY( 15)/'DRAW', 1, 10/ DATA IOPERA( 16),IX( 16),IY( 16)/'DRAW', 4, 10/ DATA IOPERA( 17),IX( 17),IY( 17)/'DRAW', 7, 11/ DATA IOPERA( 18),IX( 18),IY( 18)/'DRAW', 9, 12/ DATA IOPERA( 19),IX( 19),IY( 19)/'MOVE', 5, -2/ DATA IOPERA( 20),IX( 20),IY( 20)/'DRAW', 3, -3/ DATA IOPERA( 21),IX( 21),IY( 21)/'DRAW', 2, -5/ DATA IOPERA( 22),IX( 22),IY( 22)/'DRAW', 2, -7/ DATA IOPERA( 23),IX( 23),IY( 23)/'DRAW', 4, -9/ DATA IOPERA( 24),IX( 24),IY( 24)/'DRAW', 6, -9/ DATA IOPERA( 25),IX( 25),IY( 25)/'DRAW', 8, -8/ DATA IOPERA( 26),IX( 26),IY( 26)/'DRAW', 9, -6/ DATA IOPERA( 27),IX( 27),IY( 27)/'DRAW', 9, -4/ DATA IOPERA( 28),IX( 28),IY( 28)/'DRAW', 7, -2/ DATA IOPERA( 29),IX( 29),IY( 29)/'DRAW', 5, -2/ C DATA IXMIND( 52)/ -12/ DATA IXMAXD( 52)/ 12/ DATA IXDELD( 52)/ 24/ DATA ISTARD( 52)/ 1/ DATA NUMCOO( 52)/ 29/ C C DEFINE CHARACTER 2272--& (AMPERSAND) C DATA IOPERA( 30),IX( 30),IY( 30)/'MOVE', 9, 4/ DATA IOPERA( 31),IX( 31),IY( 31)/'DRAW', 8, 3/ DATA IOPERA( 32),IX( 32),IY( 32)/'DRAW', 9, 2/ DATA IOPERA( 33),IX( 33),IY( 33)/'DRAW', 10, 3/ DATA IOPERA( 34),IX( 34),IY( 34)/'DRAW', 10, 4/ DATA IOPERA( 35),IX( 35),IY( 35)/'DRAW', 9, 5/ DATA IOPERA( 36),IX( 36),IY( 36)/'DRAW', 8, 5/ DATA IOPERA( 37),IX( 37),IY( 37)/'DRAW', 7, 4/ DATA IOPERA( 38),IX( 38),IY( 38)/'DRAW', 6, 2/ DATA IOPERA( 39),IX( 39),IY( 39)/'DRAW', 4, -3/ DATA IOPERA( 40),IX( 40),IY( 40)/'DRAW', 2, -6/ DATA IOPERA( 41),IX( 41),IY( 41)/'DRAW', 0, -8/ DATA IOPERA( 42),IX( 42),IY( 42)/'DRAW', -2, -9/ DATA IOPERA( 43),IX( 43),IY( 43)/'DRAW', -5, -9/ DATA IOPERA( 44),IX( 44),IY( 44)/'DRAW', -8, -8/ DATA IOPERA( 45),IX( 45),IY( 45)/'DRAW', -9, -6/ DATA IOPERA( 46),IX( 46),IY( 46)/'DRAW', -9, -3/ DATA IOPERA( 47),IX( 47),IY( 47)/'DRAW', -8, -1/ DATA IOPERA( 48),IX( 48),IY( 48)/'DRAW', -2, 3/ DATA IOPERA( 49),IX( 49),IY( 49)/'DRAW', 0, 5/ DATA IOPERA( 50),IX( 50),IY( 50)/'DRAW', 1, 7/ DATA IOPERA( 51),IX( 51),IY( 51)/'DRAW', 1, 9/ DATA IOPERA( 52),IX( 52),IY( 52)/'DRAW', 0, 11/ DATA IOPERA( 53),IX( 53),IY( 53)/'DRAW', -2, 12/ DATA IOPERA( 54),IX( 54),IY( 54)/'DRAW', -4, 11/ DATA IOPERA( 55),IX( 55),IY( 55)/'DRAW', -5, 9/ DATA IOPERA( 56),IX( 56),IY( 56)/'DRAW', -5, 7/ DATA IOPERA( 57),IX( 57),IY( 57)/'DRAW', -4, 4/ DATA IOPERA( 58),IX( 58),IY( 58)/'DRAW', -2, 1/ DATA IOPERA( 59),IX( 59),IY( 59)/'DRAW', 3, -6/ DATA IOPERA( 60),IX( 60),IY( 60)/'DRAW', 5, -8/ DATA IOPERA( 61),IX( 61),IY( 61)/'DRAW', 8, -9/ DATA IOPERA( 62),IX( 62),IY( 62)/'DRAW', 9, -9/ DATA IOPERA( 63),IX( 63),IY( 63)/'DRAW', 10, -8/ DATA IOPERA( 64),IX( 64),IY( 64)/'DRAW', 10, -7/ DATA IOPERA( 65),IX( 65),IY( 65)/'MOVE', -5, -9/ DATA IOPERA( 66),IX( 66),IY( 66)/'DRAW', -7, -8/ DATA IOPERA( 67),IX( 67),IY( 67)/'DRAW', -8, -6/ DATA IOPERA( 68),IX( 68),IY( 68)/'DRAW', -8, -3/ DATA IOPERA( 69),IX( 69),IY( 69)/'DRAW', -7, -1/ DATA IOPERA( 70),IX( 70),IY( 70)/'DRAW', -5, 1/ DATA IOPERA( 71),IX( 71),IY( 71)/'MOVE', -5, 7/ DATA IOPERA( 72),IX( 72),IY( 72)/'DRAW', -4, 5/ DATA IOPERA( 73),IX( 73),IY( 73)/'DRAW', 4, -6/ DATA IOPERA( 74),IX( 74),IY( 74)/'DRAW', 6, -8/ DATA IOPERA( 75),IX( 75),IY( 75)/'DRAW', 8, -9/ C DATA IXMIND( 53)/ -12/ DATA IXMAXD( 53)/ 13/ DATA IXDELD( 53)/ 25/ DATA ISTARD( 53)/ 30/ DATA NUMCOO( 53)/ 46/ C C DEFINE CHARACTER 2273--@ (AT SIGN) C DATA IOPERA( 76),IX( 76),IY( 76)/'MOVE', 5, 4/ DATA IOPERA( 77),IX( 77),IY( 77)/'DRAW', 4, 6/ DATA IOPERA( 78),IX( 78),IY( 78)/'DRAW', 2, 7/ DATA IOPERA( 79),IX( 79),IY( 79)/'DRAW', -1, 7/ DATA IOPERA( 80),IX( 80),IY( 80)/'DRAW', -3, 6/ DATA IOPERA( 81),IX( 81),IY( 81)/'DRAW', -4, 5/ DATA IOPERA( 82),IX( 82),IY( 82)/'DRAW', -5, 2/ DATA IOPERA( 83),IX( 83),IY( 83)/'DRAW', -5, -1/ DATA IOPERA( 84),IX( 84),IY( 84)/'DRAW', -4, -3/ DATA IOPERA( 85),IX( 85),IY( 85)/'DRAW', -2, -4/ DATA IOPERA( 86),IX( 86),IY( 86)/'DRAW', 1, -4/ DATA IOPERA( 87),IX( 87),IY( 87)/'DRAW', 3, -3/ DATA IOPERA( 88),IX( 88),IY( 88)/'DRAW', 4, -1/ DATA IOPERA( 89),IX( 89),IY( 89)/'MOVE', -1, 7/ DATA IOPERA( 90),IX( 90),IY( 90)/'DRAW', -3, 5/ DATA IOPERA( 91),IX( 91),IY( 91)/'DRAW', -4, 2/ DATA IOPERA( 92),IX( 92),IY( 92)/'DRAW', -4, -1/ DATA IOPERA( 93),IX( 93),IY( 93)/'DRAW', -3, -3/ DATA IOPERA( 94),IX( 94),IY( 94)/'DRAW', -2, -4/ DATA IOPERA( 95),IX( 95),IY( 95)/'MOVE', 5, 7/ DATA IOPERA( 96),IX( 96),IY( 96)/'DRAW', 4, -1/ DATA IOPERA( 97),IX( 97),IY( 97)/'DRAW', 4, -3/ DATA IOPERA( 98),IX( 98),IY( 98)/'DRAW', 6, -4/ DATA IOPERA( 99),IX( 99),IY( 99)/'DRAW', 8, -4/ DATA IOPERA( 100),IX( 100),IY( 100)/'DRAW', 10, -2/ DATA IOPERA( 101),IX( 101),IY( 101)/'DRAW', 11, 1/ DATA IOPERA( 102),IX( 102),IY( 102)/'DRAW', 11, 3/ DATA IOPERA( 103),IX( 103),IY( 103)/'DRAW', 10, 6/ DATA IOPERA( 104),IX( 104),IY( 104)/'DRAW', 9, 8/ DATA IOPERA( 105),IX( 105),IY( 105)/'DRAW', 7, 10/ DATA IOPERA( 106),IX( 106),IY( 106)/'DRAW', 5, 11/ DATA IOPERA( 107),IX( 107),IY( 107)/'DRAW', 2, 12/ DATA IOPERA( 108),IX( 108),IY( 108)/'DRAW', -1, 12/ DATA IOPERA( 109),IX( 109),IY( 109)/'DRAW', -4, 11/ DATA IOPERA( 110),IX( 110),IY( 110)/'DRAW', -6, 10/ DATA IOPERA( 111),IX( 111),IY( 111)/'DRAW', -8, 8/ DATA IOPERA( 112),IX( 112),IY( 112)/'DRAW', -9, 6/ DATA IOPERA( 113),IX( 113),IY( 113)/'DRAW', -10, 3/ DATA IOPERA( 114),IX( 114),IY( 114)/'DRAW', -10, 0/ DATA IOPERA( 115),IX( 115),IY( 115)/'DRAW', -9, -3/ DATA IOPERA( 116),IX( 116),IY( 116)/'DRAW', -8, -5/ DATA IOPERA( 117),IX( 117),IY( 117)/'DRAW', -6, -7/ DATA IOPERA( 118),IX( 118),IY( 118)/'DRAW', -4, -8/ DATA IOPERA( 119),IX( 119),IY( 119)/'DRAW', -1, -9/ DATA IOPERA( 120),IX( 120),IY( 120)/'DRAW', 2, -9/ DATA IOPERA( 121),IX( 121),IY( 121)/'DRAW', 5, -8/ DATA IOPERA( 122),IX( 122),IY( 122)/'DRAW', 7, -7/ DATA IOPERA( 123),IX( 123),IY( 123)/'DRAW', 8, -6/ DATA IOPERA( 124),IX( 124),IY( 124)/'MOVE', 6, 7/ DATA IOPERA( 125),IX( 125),IY( 125)/'DRAW', 5, -1/ DATA IOPERA( 126),IX( 126),IY( 126)/'DRAW', 5, -3/ DATA IOPERA( 127),IX( 127),IY( 127)/'DRAW', 6, -4/ C DATA IXMIND( 54)/ -13/ DATA IXMAXD( 54)/ 14/ DATA IXDELD( 54)/ 27/ DATA ISTARD( 54)/ 76/ DATA NUMCOO( 54)/ 52/ C C DEFINE CHARACTER 2274--$ (DOLLAR SIGN) C DATA IOPERA( 128),IX( 128),IY( 128)/'MOVE', -2, 16/ DATA IOPERA( 129),IX( 129),IY( 129)/'DRAW', -2, -13/ DATA IOPERA( 130),IX( 130),IY( 130)/'MOVE', 2, 16/ DATA IOPERA( 131),IX( 131),IY( 131)/'DRAW', 2, -13/ DATA IOPERA( 132),IX( 132),IY( 132)/'MOVE', 6, 9/ DATA IOPERA( 133),IX( 133),IY( 133)/'DRAW', 5, 8/ DATA IOPERA( 134),IX( 134),IY( 134)/'DRAW', 6, 7/ DATA IOPERA( 135),IX( 135),IY( 135)/'DRAW', 7, 8/ DATA IOPERA( 136),IX( 136),IY( 136)/'DRAW', 7, 9/ DATA IOPERA( 137),IX( 137),IY( 137)/'DRAW', 5, 11/ DATA IOPERA( 138),IX( 138),IY( 138)/'DRAW', 2, 12/ DATA IOPERA( 139),IX( 139),IY( 139)/'DRAW', -2, 12/ DATA IOPERA( 140),IX( 140),IY( 140)/'DRAW', -5, 11/ DATA IOPERA( 141),IX( 141),IY( 141)/'DRAW', -7, 9/ DATA IOPERA( 142),IX( 142),IY( 142)/'DRAW', -7, 7/ DATA IOPERA( 143),IX( 143),IY( 143)/'DRAW', -6, 5/ DATA IOPERA( 144),IX( 144),IY( 144)/'DRAW', -5, 4/ DATA IOPERA( 145),IX( 145),IY( 145)/'DRAW', -3, 3/ DATA IOPERA( 146),IX( 146),IY( 146)/'DRAW', 3, 1/ DATA IOPERA( 147),IX( 147),IY( 147)/'DRAW', 5, 0/ DATA IOPERA( 148),IX( 148),IY( 148)/'DRAW', 7, -2/ DATA IOPERA( 149),IX( 149),IY( 149)/'MOVE', -7, 7/ DATA IOPERA( 150),IX( 150),IY( 150)/'DRAW', -5, 5/ DATA IOPERA( 151),IX( 151),IY( 151)/'DRAW', -3, 4/ DATA IOPERA( 152),IX( 152),IY( 152)/'DRAW', 3, 2/ DATA IOPERA( 153),IX( 153),IY( 153)/'DRAW', 5, 1/ DATA IOPERA( 154),IX( 154),IY( 154)/'DRAW', 6, 0/ DATA IOPERA( 155),IX( 155),IY( 155)/'DRAW', 7, -2/ DATA IOPERA( 156),IX( 156),IY( 156)/'DRAW', 7, -6/ DATA IOPERA( 157),IX( 157),IY( 157)/'DRAW', 5, -8/ DATA IOPERA( 158),IX( 158),IY( 158)/'DRAW', 2, -9/ DATA IOPERA( 159),IX( 159),IY( 159)/'DRAW', -2, -9/ DATA IOPERA( 160),IX( 160),IY( 160)/'DRAW', -5, -8/ DATA IOPERA( 161),IX( 161),IY( 161)/'DRAW', -7, -6/ DATA IOPERA( 162),IX( 162),IY( 162)/'DRAW', -7, -5/ DATA IOPERA( 163),IX( 163),IY( 163)/'DRAW', -6, -4/ DATA IOPERA( 164),IX( 164),IY( 164)/'DRAW', -5, -5/ DATA IOPERA( 165),IX( 165),IY( 165)/'DRAW', -6, -6/ C DATA IXMIND( 55)/ -10/ DATA IXMAXD( 55)/ 10/ DATA IXDELD( 55)/ 20/ DATA ISTARD( 55)/ 128/ DATA NUMCOO( 55)/ 38/ C C DEFINE CHARACTER 2275--# (NUMBER SIGN) C DATA IOPERA( 166),IX( 166),IY( 166)/'MOVE', 1, 12/ DATA IOPERA( 167),IX( 167),IY( 167)/'DRAW', -6, -16/ DATA IOPERA( 168),IX( 168),IY( 168)/'MOVE', 7, 12/ DATA IOPERA( 169),IX( 169),IY( 169)/'DRAW', 0, -16/ DATA IOPERA( 170),IX( 170),IY( 170)/'MOVE', -6, 1/ DATA IOPERA( 171),IX( 171),IY( 171)/'DRAW', 8, 1/ DATA IOPERA( 172),IX( 172),IY( 172)/'MOVE', -7, -5/ DATA IOPERA( 173),IX( 173),IY( 173)/'DRAW', 7, -5/ C DATA IXMIND( 56)/ -10/ DATA IXMAXD( 56)/ 11/ DATA IXDELD( 56)/ 21/ DATA ISTARD( 56)/ 166/ DATA NUMCOO( 56)/ 8/ C C DEFINE CHARACTER 2276--PARAGRAP (PARAGRAPH SYMBOL) C DATA IOPERA( 174),IX( 174),IY( 174)/'MOVE', 3, 9/ DATA IOPERA( 175),IX( 175),IY( 175)/'DRAW', 2, 8/ DATA IOPERA( 176),IX( 176),IY( 176)/'DRAW', 3, 7/ DATA IOPERA( 177),IX( 177),IY( 177)/'DRAW', 4, 8/ DATA IOPERA( 178),IX( 178),IY( 178)/'DRAW', 4, 9/ DATA IOPERA( 179),IX( 179),IY( 179)/'DRAW', 3, 11/ DATA IOPERA( 180),IX( 180),IY( 180)/'DRAW', 1, 12/ DATA IOPERA( 181),IX( 181),IY( 181)/'DRAW', -1, 12/ DATA IOPERA( 182),IX( 182),IY( 182)/'DRAW', -3, 11/ DATA IOPERA( 183),IX( 183),IY( 183)/'DRAW', -4, 9/ DATA IOPERA( 184),IX( 184),IY( 184)/'DRAW', -4, 7/ DATA IOPERA( 185),IX( 185),IY( 185)/'DRAW', -3, 5/ DATA IOPERA( 186),IX( 186),IY( 186)/'DRAW', -1, 3/ DATA IOPERA( 187),IX( 187),IY( 187)/'DRAW', 4, 0/ DATA IOPERA( 188),IX( 188),IY( 188)/'MOVE', -3, 5/ DATA IOPERA( 189),IX( 189),IY( 189)/'DRAW', 2, 2/ DATA IOPERA( 190),IX( 190),IY( 190)/'DRAW', 4, 0/ DATA IOPERA( 191),IX( 191),IY( 191)/'DRAW', 5, -2/ DATA IOPERA( 192),IX( 192),IY( 192)/'DRAW', 5, -4/ DATA IOPERA( 193),IX( 193),IY( 193)/'DRAW', 4, -6/ DATA IOPERA( 194),IX( 194),IY( 194)/'DRAW', 2, -8/ DATA IOPERA( 195),IX( 195),IY( 195)/'MOVE', -2, 4/ DATA IOPERA( 196),IX( 196),IY( 196)/'DRAW', -4, 2/ DATA IOPERA( 197),IX( 197),IY( 197)/'DRAW', -5, 0/ DATA IOPERA( 198),IX( 198),IY( 198)/'DRAW', -5, -2/ DATA IOPERA( 199),IX( 199),IY( 199)/'DRAW', -4, -4/ DATA IOPERA( 200),IX( 200),IY( 200)/'DRAW', -2, -6/ DATA IOPERA( 201),IX( 201),IY( 201)/'DRAW', 3, -9/ DATA IOPERA( 202),IX( 202),IY( 202)/'MOVE', -4, -4/ DATA IOPERA( 203),IX( 203),IY( 203)/'DRAW', 1, -7/ DATA IOPERA( 204),IX( 204),IY( 204)/'DRAW', 3, -9/ DATA IOPERA( 205),IX( 205),IY( 205)/'DRAW', 4, -11/ DATA IOPERA( 206),IX( 206),IY( 206)/'DRAW', 4, -13/ DATA IOPERA( 207),IX( 207),IY( 207)/'DRAW', 3, -15/ DATA IOPERA( 208),IX( 208),IY( 208)/'DRAW', 1, -16/ DATA IOPERA( 209),IX( 209),IY( 209)/'DRAW', -1, -16/ DATA IOPERA( 210),IX( 210),IY( 210)/'DRAW', -3, -15/ DATA IOPERA( 211),IX( 211),IY( 211)/'DRAW', -4, -13/ DATA IOPERA( 212),IX( 212),IY( 212)/'DRAW', -4, -12/ DATA IOPERA( 213),IX( 213),IY( 213)/'DRAW', -3, -11/ DATA IOPERA( 214),IX( 214),IY( 214)/'DRAW', -2, -12/ DATA IOPERA( 215),IX( 215),IY( 215)/'DRAW', -3, -13/ C DATA IXMIND( 57)/ -8/ DATA IXMAXD( 57)/ 8/ DATA IXDELD( 57)/ 16/ DATA ISTARD( 57)/ 174/ DATA NUMCOO( 57)/ 42/ C C DEFINE CHARACTER 2277--DAGGER (DAGGER) C DATA IOPERA( 216),IX( 216),IY( 216)/'MOVE', 0, 12/ DATA IOPERA( 217),IX( 217),IY( 217)/'DRAW', -1, 10/ DATA IOPERA( 218),IX( 218),IY( 218)/'DRAW', 0, 8/ DATA IOPERA( 219),IX( 219),IY( 219)/'DRAW', 1, 10/ DATA IOPERA( 220),IX( 220),IY( 220)/'DRAW', 0, 12/ DATA IOPERA( 221),IX( 221),IY( 221)/'MOVE', 0, 12/ DATA IOPERA( 222),IX( 222),IY( 222)/'DRAW', 0, -16/ DATA IOPERA( 223),IX( 223),IY( 223)/'MOVE', 0, 1/ DATA IOPERA( 224),IX( 224),IY( 224)/'DRAW', -1, -2/ DATA IOPERA( 225),IX( 225),IY( 225)/'DRAW', 0, -16/ DATA IOPERA( 226),IX( 226),IY( 226)/'DRAW', 1, -2/ DATA IOPERA( 227),IX( 227),IY( 227)/'DRAW', 0, 1/ DATA IOPERA( 228),IX( 228),IY( 228)/'MOVE', -6, 5/ DATA IOPERA( 229),IX( 229),IY( 229)/'DRAW', -4, 4/ DATA IOPERA( 230),IX( 230),IY( 230)/'DRAW', -2, 5/ DATA IOPERA( 231),IX( 231),IY( 231)/'DRAW', -4, 6/ DATA IOPERA( 232),IX( 232),IY( 232)/'DRAW', -6, 5/ DATA IOPERA( 233),IX( 233),IY( 233)/'MOVE', -6, 5/ DATA IOPERA( 234),IX( 234),IY( 234)/'DRAW', 6, 5/ DATA IOPERA( 235),IX( 235),IY( 235)/'MOVE', 2, 5/ DATA IOPERA( 236),IX( 236),IY( 236)/'DRAW', 4, 4/ DATA IOPERA( 237),IX( 237),IY( 237)/'DRAW', 6, 5/ DATA IOPERA( 238),IX( 238),IY( 238)/'DRAW', 4, 6/ DATA IOPERA( 239),IX( 239),IY( 239)/'DRAW', 2, 5/ C DATA IXMIND( 58)/ -8/ DATA IXMAXD( 58)/ 8/ DATA IXDELD( 58)/ 16/ DATA ISTARD( 58)/ 216/ DATA NUMCOO( 58)/ 24/ C C DEFINE CHARACTER 2278--DDAGGER (DOUBLE DAGGER) C DATA IOPERA( 240),IX( 240),IY( 240)/'MOVE', 0, 12/ DATA IOPERA( 241),IX( 241),IY( 241)/'DRAW', -1, 10/ DATA IOPERA( 242),IX( 242),IY( 242)/'DRAW', 0, 8/ DATA IOPERA( 243),IX( 243),IY( 243)/'DRAW', 1, 10/ DATA IOPERA( 244),IX( 244),IY( 244)/'DRAW', 0, 12/ DATA IOPERA( 245),IX( 245),IY( 245)/'MOVE', 0, 12/ DATA IOPERA( 246),IX( 246),IY( 246)/'DRAW', 0, -2/ DATA IOPERA( 247),IX( 247),IY( 247)/'MOVE', 0, 2/ DATA IOPERA( 248),IX( 248),IY( 248)/'DRAW', -1, 0/ DATA IOPERA( 249),IX( 249),IY( 249)/'DRAW', 1, -4/ DATA IOPERA( 250),IX( 250),IY( 250)/'DRAW', 0, -6/ DATA IOPERA( 251),IX( 251),IY( 251)/'DRAW', -1, -4/ DATA IOPERA( 252),IX( 252),IY( 252)/'DRAW', 1, 0/ DATA IOPERA( 253),IX( 253),IY( 253)/'DRAW', 0, 2/ DATA IOPERA( 254),IX( 254),IY( 254)/'MOVE', 0, -2/ DATA IOPERA( 255),IX( 255),IY( 255)/'DRAW', 0, -16/ DATA IOPERA( 256),IX( 256),IY( 256)/'MOVE', 0, -12/ DATA IOPERA( 257),IX( 257),IY( 257)/'DRAW', -1, -14/ DATA IOPERA( 258),IX( 258),IY( 258)/'DRAW', 0, -16/ DATA IOPERA( 259),IX( 259),IY( 259)/'DRAW', 1, -14/ DATA IOPERA( 260),IX( 260),IY( 260)/'DRAW', 0, -12/ DATA IOPERA( 261),IX( 261),IY( 261)/'MOVE', -6, 5/ DATA IOPERA( 262),IX( 262),IY( 262)/'DRAW', -4, 4/ DATA IOPERA( 263),IX( 263),IY( 263)/'DRAW', -2, 5/ DATA IOPERA( 264),IX( 264),IY( 264)/'DRAW', -4, 6/ DATA IOPERA( 265),IX( 265),IY( 265)/'DRAW', -6, 5/ DATA IOPERA( 266),IX( 266),IY( 266)/'MOVE', -6, 5/ DATA IOPERA( 267),IX( 267),IY( 267)/'DRAW', 6, 5/ DATA IOPERA( 268),IX( 268),IY( 268)/'MOVE', 2, 5/ DATA IOPERA( 269),IX( 269),IY( 269)/'DRAW', 4, 4/ DATA IOPERA( 270),IX( 270),IY( 270)/'DRAW', 6, 5/ DATA IOPERA( 271),IX( 271),IY( 271)/'DRAW', 4, 6/ DATA IOPERA( 272),IX( 272),IY( 272)/'DRAW', 2, 5/ DATA IOPERA( 273),IX( 273),IY( 273)/'MOVE', -6, -9/ DATA IOPERA( 274),IX( 274),IY( 274)/'DRAW', -4, -10/ DATA IOPERA( 275),IX( 275),IY( 275)/'DRAW', -2, -9/ DATA IOPERA( 276),IX( 276),IY( 276)/'DRAW', -4, -8/ DATA IOPERA( 277),IX( 277),IY( 277)/'DRAW', -6, -9/ DATA IOPERA( 278),IX( 278),IY( 278)/'MOVE', -6, -9/ DATA IOPERA( 279),IX( 279),IY( 279)/'DRAW', 6, -9/ DATA IOPERA( 280),IX( 280),IY( 280)/'MOVE', 2, -9/ DATA IOPERA( 281),IX( 281),IY( 281)/'DRAW', 4, -10/ DATA IOPERA( 282),IX( 282),IY( 282)/'DRAW', 6, -9/ DATA IOPERA( 283),IX( 283),IY( 283)/'DRAW', 4, -8/ DATA IOPERA( 284),IX( 284),IY( 284)/'DRAW', 2, -9/ C DATA IXMIND( 59)/ -8/ DATA IXMAXD( 59)/ 8/ DATA IXDELD( 59)/ 16/ DATA ISTARD( 59)/ 240/ DATA NUMCOO( 59)/ 45/ C C DEFINE CHARACTER 2279--THEREEXI (THERE EXISTS SIGN) C DATA IOPERA( 285),IX( 285),IY( 285)/'MOVE', 6, 12/ DATA IOPERA( 286),IX( 286),IY( 286)/'DRAW', 6, -9/ DATA IOPERA( 287),IX( 287),IY( 287)/'MOVE', -7, 12/ DATA IOPERA( 288),IX( 288),IY( 288)/'DRAW', 6, 12/ DATA IOPERA( 289),IX( 289),IY( 289)/'MOVE', -2, 2/ DATA IOPERA( 290),IX( 290),IY( 290)/'DRAW', 6, 2/ DATA IOPERA( 291),IX( 291),IY( 291)/'MOVE', -7, -9/ DATA IOPERA( 292),IX( 292),IY( 292)/'DRAW', 6, -9/ C DATA IXMIND( 60)/ -9/ DATA IXMAXD( 60)/ 10/ DATA IXDELD( 60)/ 19/ DATA ISTARD( 60)/ 285/ DATA NUMCOO( 60)/ 8/ 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(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'MATH')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DMATH3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHARN 52 FORMAT('ICHARN = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGG4,ISUBG4,IFOUND,IERROR 59 FORMAT('IBUGG4,ISUBG4,IFOUND,IERROR = ',A4,2X,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 C ********************************************* C ** STEP 3-- ** C ** ADJUST THE COORDINATES IF A CIRCLE. ** C ** IF THE CHARACTER IS A CIRCLE ** C ** THEN SCALE THE FIGURE DOWN FROM ** C ** -17 TO 17 TO THE MORE USUAL -7 TO 7. ** C ** THE ORIGINAL CIRCLE WAS FROM -17 TO 17 ** C ** RATHER THAN -7 TO 7 IN ** C ** ORDER TO INCREASE THE RESOLUTION ** C ** AND GIVE A 32 POINT CIRCLE RATHER ** C ** THAN A 16 POINT CIRCLE. ** C ********************************************* C IF(ICHARN.EQ.102)GOTO1210 GOTO1290 C 1210 CONTINUE AFACTO=7.0/17.0 DO1220J=1,NUMCO X(J)=X(J)*AFACTO Y(J)=Y(J)*AFACTO 1220 CONTINUE IXMINS=(-7) IXMAXS=7 IXDELS=14 C 1290 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'MATH')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DMATH3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGG4,ISUBG4,IFOUND,IERROR 9012 FORMAT('IBUGG4,ISUBG4,IFOUND,IERROR = ',A4,2X,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 DMATH4(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES C FOR MATH SYMBOLS (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-921-3651 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 UPDATED --APRIL 1987. C UPDATED --AUGUST 1992. ADD ARROW CHARACTER. 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(150) DIMENSION IXMAXD(150) DIMENSION IXDELD(150) DIMENSION ISTARD(150) DIMENSION NUMCOO(150) C C-----COMMON---------------------------------------------------------- C 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-----DATA STATEMENTS------------------------------------------------- C DEFINE CHARACTER 2401--PRODUCT (PRODUCT SIGN) C DATA IOPERA( 1),IX( 1),IY( 1)/'MOVE', -10, 16/ DATA IOPERA( 2),IX( 2),IY( 2)/'DRAW', -10, -16/ DATA IOPERA( 3),IX( 3),IY( 3)/'MOVE', -9, 16/ DATA IOPERA( 4),IX( 4),IY( 4)/'DRAW', -9, -16/ DATA IOPERA( 5),IX( 5),IY( 5)/'MOVE', 9, 16/ DATA IOPERA( 6),IX( 6),IY( 6)/'DRAW', 9, -16/ DATA IOPERA( 7),IX( 7),IY( 7)/'MOVE', 10, 16/ DATA IOPERA( 8),IX( 8),IY( 8)/'DRAW', 10, -16/ DATA IOPERA( 9),IX( 9),IY( 9)/'MOVE', -14, 16/ DATA IOPERA( 10),IX( 10),IY( 10)/'DRAW', 14, 16/ DATA IOPERA( 11),IX( 11),IY( 11)/'MOVE', -14, -16/ DATA IOPERA( 12),IX( 12),IY( 12)/'DRAW', -5, -16/ DATA IOPERA( 13),IX( 13),IY( 13)/'MOVE', 5, -16/ DATA IOPERA( 14),IX( 14),IY( 14)/'DRAW', 14, -16/ C DATA IXMIND( 61)/ -17/ DATA IXMAXD( 61)/ 17/ DATA IXDELD( 61)/ 34/ DATA ISTARD( 61)/ 1/ DATA NUMCOO( 61)/ 14/ C C DEFINE CHARACTER 2402--SUMMATION (SUMMATION SIGN) C DATA IOPERA( 15),IX( 15),IY( 15)/'MOVE', -11, 16/ DATA IOPERA( 16),IX( 16),IY( 16)/'DRAW', -1, 2/ DATA IOPERA( 17),IX( 17),IY( 17)/'DRAW', -12, -16/ DATA IOPERA( 18),IX( 18),IY( 18)/'MOVE', -12, 16/ DATA IOPERA( 19),IX( 19),IY( 19)/'DRAW', -2, 2/ DATA IOPERA( 20),IX( 20),IY( 20)/'MOVE', -13, 16/ DATA IOPERA( 21),IX( 21),IY( 21)/'DRAW', -2, 1/ DATA IOPERA( 22),IX( 22),IY( 22)/'MOVE', -13, 16/ DATA IOPERA( 23),IX( 23),IY( 23)/'DRAW', 10, 16/ DATA IOPERA( 24),IX( 24),IY( 24)/'DRAW', 12, 9/ DATA IOPERA( 25),IX( 25),IY( 25)/'DRAW', 9, 16/ DATA IOPERA( 26),IX( 26),IY( 26)/'MOVE', -11, -15/ DATA IOPERA( 27),IX( 27),IY( 27)/'DRAW', 10, -15/ DATA IOPERA( 28),IX( 28),IY( 28)/'MOVE', -12, -16/ DATA IOPERA( 29),IX( 29),IY( 29)/'DRAW', 10, -16/ DATA IOPERA( 30),IX( 30),IY( 30)/'DRAW', 12, -9/ DATA IOPERA( 31),IX( 31),IY( 31)/'DRAW', 9, -16/ C DATA IXMIND( 62)/ -16/ DATA IXMAXD( 62)/ 15/ DATA IXDELD( 62)/ 31/ DATA ISTARD( 62)/ 15/ DATA NUMCOO( 62)/ 17/ C C DEFINE CHARACTER 2740--THEREEXI (THERE EXISTS SIGN) C DATA IOPERA( 32),IX( 32),IY( 32)/'MOVE', 0, 9/ DATA IOPERA( 33),IX( 33),IY( 33)/'DRAW', -1, 8/ DATA IOPERA( 34),IX( 34),IY( 34)/'DRAW', 0, 7/ DATA IOPERA( 35),IX( 35),IY( 35)/'DRAW', 1, 8/ DATA IOPERA( 36),IX( 36),IY( 36)/'DRAW', 0, 9/ DATA IOPERA( 37),IX( 37),IY( 37)/'MOVE', -9, -7/ DATA IOPERA( 38),IX( 38),IY( 38)/'DRAW', -10, -8/ DATA IOPERA( 39),IX( 39),IY( 39)/'DRAW', -9, -9/ DATA IOPERA( 40),IX( 40),IY( 40)/'DRAW', -8, -8/ DATA IOPERA( 41),IX( 41),IY( 41)/'DRAW', -9, -7/ DATA IOPERA( 42),IX( 42),IY( 42)/'MOVE', 9, -7/ DATA IOPERA( 43),IX( 43),IY( 43)/'DRAW', 8, -8/ DATA IOPERA( 44),IX( 44),IY( 44)/'DRAW', 9, -9/ DATA IOPERA( 45),IX( 45),IY( 45)/'DRAW', 10, -8/ DATA IOPERA( 46),IX( 46),IY( 46)/'DRAW', 9, -7/ C DATA IXMIND( 63)/ -13/ DATA IXMAXD( 63)/ 13/ DATA IXDELD( 63)/ 26/ DATA ISTARD( 63)/ 32/ DATA NUMCOO( 63)/ 15/ C C DEFINE CHARACTER XX--LVBAR (LONGER VERTICAL BAR) C DATA IOPERA( 47),IX( 47),IY( 47)/'MOVE', 0, 20/ DATA IOPERA( 48),IX( 48),IY( 48)/'DRAW', 0, -20/ C DATA IXMIND( 64)/ -2/ DATA IXMAXD( 64)/ 2/ DATA IXDELD( 64)/ 4/ DATA ISTARD( 64)/ 47/ DATA NUMCOO( 64)/ 2/ C C DEFINE CHARACTER 2800--HBAR (HORIZONTAL BAR) C DATA IOPERA( 49),IX( 49),IY( 49)/'MOVE', -14, 0/ DATA IOPERA( 50),IX( 50),IY( 50)/'DRAW', 14, 0/ C DATA IXMIND( 65)/ -14/ DATA IXMAXD( 65)/ 14/ DATA IXDELD( 65)/ 28/ DATA ISTARD( 65)/ 49/ DATA NUMCOO( 65)/ 2/ C C DEFINE CHARACTER 2796--LHBAR (LONGER HORIZONTAL BAR) C DATA IOPERA( 51),IX( 51),IY( 51)/'MOVE', -20, 0/ DATA IOPERA( 52),IX( 52),IY( 52)/'DRAW', 20, 0/ C DATA IXMIND( 66)/ -20/ DATA IXMAXD( 66)/ 20/ DATA IXDELD( 66)/ 40/ DATA ISTARD( 66)/ 51/ DATA NUMCOO( 66)/ 2/ C C DEFINE CHARACTER XXX--CENTERED POINT C DATA IOPERA( 53),IX( 53),IY( 53)/'MOVE',0,0/ C DATA IXMIND(101)/-2/ DATA IXMAXD(101)/2/ DATA IXDELD(101)/4/ DATA ISTARD(101)/ 53/ DATA NUMCOO(101)/1/ C C DEFINE CHARACTER 905--CIRCLE C DATA IOPERA( 54),IX( 54),IY( 54)/'MOVE',-2,17/ DATA IOPERA( 55),IX( 55),IY( 55)/'DRAW',-6,16/ DATA IOPERA( 56),IX( 56),IY( 56)/'DRAW',-8,15/ DATA IOPERA( 57),IX( 57),IY( 57)/'DRAW',-11,13/ DATA IOPERA( 58),IX( 58),IY( 58)/'DRAW',-13,11/ DATA IOPERA( 59),IX( 59),IY( 59)/'DRAW',-15,8/ DATA IOPERA( 60),IX( 60),IY( 60)/'DRAW',-16,6/ DATA IOPERA( 61),IX( 61),IY( 61)/'DRAW',-17,2/ DATA IOPERA( 62),IX( 62),IY( 62)/'DRAW',-17,-2/ DATA IOPERA( 63),IX( 63),IY( 63)/'DRAW',-16,-6/ DATA IOPERA( 64),IX( 64),IY( 64)/'DRAW',-15,-8/ DATA IOPERA( 65),IX( 65),IY( 65)/'DRAW',-13,-11/ DATA IOPERA( 66),IX( 66),IY( 66)/'DRAW',-11,-13/ DATA IOPERA( 67),IX( 67),IY( 67)/'DRAW',-8,-15/ DATA IOPERA( 68),IX( 68),IY( 68)/'DRAW',-6,-16/ DATA IOPERA( 69),IX( 69),IY( 69)/'DRAW',-2,-17/ DATA IOPERA( 70),IX( 70),IY( 70)/'DRAW',2,-17/ DATA IOPERA( 71),IX( 71),IY( 71)/'DRAW',6,-16/ DATA IOPERA( 72),IX( 72),IY( 72)/'DRAW',8,-15/ DATA IOPERA( 73),IX( 73),IY( 73)/'DRAW',11,-13/ DATA IOPERA( 74),IX( 74),IY( 74)/'DRAW',13,-11/ DATA IOPERA( 75),IX( 75),IY( 75)/'DRAW',15,-8/ DATA IOPERA( 76),IX( 76),IY( 76)/'DRAW',16,-6/ DATA IOPERA( 77),IX( 77),IY( 77)/'DRAW',17,-2/ DATA IOPERA( 78),IX( 78),IY( 78)/'DRAW',17,2/ DATA IOPERA( 79),IX( 79),IY( 79)/'DRAW',16,6/ DATA IOPERA( 80),IX( 80),IY( 80)/'DRAW',15,8/ DATA IOPERA( 81),IX( 81),IY( 81)/'DRAW',13,11/ DATA IOPERA( 82),IX( 82),IY( 82)/'DRAW',11,13/ DATA IOPERA( 83),IX( 83),IY( 83)/'DRAW',8,15/ DATA IOPERA( 84),IX( 84),IY( 84)/'DRAW',6,16/ DATA IOPERA( 85),IX( 85),IY( 85)/'DRAW',2,17/ DATA IOPERA( 86),IX( 86),IY( 86)/'DRAW',-2,17/ C DATA IXMIND(102)/-17/ DATA IXMAXD(102)/17/ DATA IXDELD(102)/34/ DATA ISTARD(102)/ 54/ DATA NUMCOO(102)/33/ C C DEFINE CHARACTER 841--SQUARE C DATA IOPERA( 87),IX( 87),IY( 87)/'MOVE',-6,-6/ DATA IOPERA( 88),IX( 88),IY( 88)/'DRAW',6,-6/ DATA IOPERA( 89),IX( 89),IY( 89)/'DRAW',6,6/ DATA IOPERA( 90),IX( 90),IY( 90)/'DRAW',-6,6/ DATA IOPERA( 91),IX( 91),IY( 91)/'DRAW',-6,-6/ C DATA IXMIND(103)/-6/ DATA IXMAXD(103)/6/ DATA IXDELD(103)/12/ DATA ISTARD(103)/ 87/ DATA NUMCOO(103)/5/ C C DEFINE CHARACTER 842--TRIANGLE C DATA IOPERA( 92),IX( 92),IY( 92)/'MOVE',0,8/ DATA IOPERA( 93),IX( 93),IY( 93)/'DRAW',-7,-4/ DATA IOPERA( 94),IX( 94),IY( 94)/'DRAW',7,-4/ DATA IOPERA( 95),IX( 95),IY( 95)/'DRAW',0,8/ C DATA IXMIND(104)/-7/ DATA IXMAXD(104)/7/ DATA IXDELD(104)/14/ DATA ISTARD(104)/ 92/ DATA NUMCOO(104)/4/ C C DEFINE CHARACTER 843--DIAMOND C DATA IOPERA( 96),IX( 96),IY( 96)/'MOVE',0,10/ DATA IOPERA( 97),IX( 97),IY( 97)/'DRAW',-6,0/ DATA IOPERA( 98),IX( 98),IY( 98)/'DRAW',0,-10/ DATA IOPERA( 99),IX( 99),IY( 99)/'DRAW',6,0/ DATA IOPERA( 100),IX( 100),IY( 100)/'DRAW',0,10/ C DATA IXMIND(105)/-6/ DATA IXMAXD(105)/6/ DATA IXDELD(105)/12/ DATA ISTARD(105)/ 96/ DATA NUMCOO(105)/5/ C C DEFINE CHARACTER 844--STAR C DATA IOPERA( 101),IX( 101),IY( 101)/'MOVE',0,9/ DATA IOPERA( 102),IX( 102),IY( 102)/'DRAW',-2,3/ DATA IOPERA( 103),IX( 103),IY( 103)/'DRAW',-8,3/ DATA IOPERA( 104),IX( 104),IY( 104)/'DRAW',-3,-1/ DATA IOPERA( 105),IX( 105),IY( 105)/'DRAW',-5,-7/ DATA IOPERA( 106),IX( 106),IY( 106)/'DRAW',0,-3/ DATA IOPERA( 107),IX( 107),IY( 107)/'DRAW',5,-7/ DATA IOPERA( 108),IX( 108),IY( 108)/'DRAW',3,-1/ DATA IOPERA( 109),IX( 109),IY( 109)/'DRAW',8,3/ DATA IOPERA( 110),IX( 110),IY( 110)/'DRAW',2,3/ DATA IOPERA( 111),IX( 111),IY( 111)/'DRAW',0,9/ C DATA IXMIND(106)/-8/ DATA IXMAXD(106)/8/ DATA IXDELD(106)/16/ DATA ISTARD(106)/ 101/ DATA NUMCOO(106)/11/ C C DEFINE CHARACTER 847--ASTERISK C DATA IOPERA( 112),IX( 112),IY( 112)/'MOVE',0,6/ DATA IOPERA( 113),IX( 113),IY( 113)/'DRAW',0,-6/ DATA IOPERA( 114),IX( 114),IY( 114)/'MOVE',-5,3/ DATA IOPERA( 115),IX( 115),IY( 115)/'DRAW',5,-3/ DATA IOPERA( 116),IX( 116),IY( 116)/'MOVE',5,3/ DATA IOPERA( 117),IX( 117),IY( 117)/'DRAW',-5,-3/ C DATA IXMIND(107)/-5/ DATA IXMAXD(107)/5/ DATA IXDELD(107)/10/ DATA ISTARD(107)/ 112/ DATA NUMCOO(107)/6/ C C DEFINE CHARACTER XXX--REVERSE TRIANGLE C DATA IOPERA( 118),IX( 118),IY( 118)/'MOVE',0,-8/ DATA IOPERA( 119),IX( 119),IY( 119)/'DRAW',-7,4/ DATA IOPERA( 120),IX( 120),IY( 120)/'DRAW',7,4/ DATA IOPERA( 121),IX( 121),IY( 121)/'DRAW',0,-8/ C DATA IXMIND(108)/-7/ DATA IXMAXD(108)/7/ DATA IXDELD(108)/14/ DATA ISTARD(108)/ 118/ DATA NUMCOO(108)/4/ C C DEFINE CHARACTER XX--VERTICAL BAR C DATA IOPERA( 122),IX( 122),IY( 122)/'MOVE',0,8/ DATA IOPERA( 123),IX( 123),IY( 123)/'DRAW',0,-8/ C DATA IXMIND(109)/-2/ DATA IXMAXD(109)/2/ DATA IXDELD(109)/4/ DATA ISTARD(109)/ 122/ DATA NUMCOO(109)/2/ C C DEFINE CHARACTER XX--HORIZONTAL BAR C DATA IOPERA( 124),IX( 124),IY( 124)/'MOVE',-8,0/ DATA IOPERA( 125),IX( 125),IY( 125)/'DRAW',8,0/ C DATA IXMIND(110)/-8/ DATA IXMAXD(110)/8/ DATA IXDELD(110)/16/ DATA ISTARD(110)/ 124/ DATA NUMCOO(110)/2/ C C DEFINE CHARACTER 2262--UP ARROW C DATA IOPERA( 126),IX( 126),IY( 126)/'MOVE',-2,6/ DATA IOPERA( 127),IX( 127),IY( 127)/'DRAW',0,9/ DATA IOPERA( 128),IX( 128),IY( 128)/'DRAW',2,6/ DATA IOPERA( 129),IX( 129),IY( 129)/'MOVE',-5,3/ DATA IOPERA( 130),IX( 130),IY( 130)/'DRAW',0,8/ DATA IOPERA( 131),IX( 131),IY( 131)/'DRAW',5,3/ DATA IOPERA( 132),IX( 132),IY( 132)/'MOVE',0,8/ DATA IOPERA( 133),IX( 133),IY( 133)/'DRAW',0,-9/ C DATA IXMIND(111)/-8/ DATA IXMAXD(111)/8/ DATA IXDELD(111)/16/ DATA ISTARD(111)/ 126/ DATA NUMCOO(111)/8/ C C DEFINE CHARACTER 2264--DOWN ARROW C DATA IOPERA( 134),IX( 134),IY( 134)/'MOVE',-2,-6/ DATA IOPERA( 135),IX( 135),IY( 135)/'DRAW',0,-9/ DATA IOPERA( 136),IX( 136),IY( 136)/'DRAW',2,-6/ DATA IOPERA( 137),IX( 137),IY( 137)/'MOVE',-5,-3/ DATA IOPERA( 138),IX( 138),IY( 138)/'DRAW',0,-8/ DATA IOPERA( 139),IX( 139),IY( 139)/'DRAW',5,-3/ DATA IOPERA( 140),IX( 140),IY( 140)/'MOVE',0,9/ DATA IOPERA( 141),IX( 141),IY( 141)/'DRAW',0,-8/ C DATA IXMIND(112)/-8/ DATA IXMAXD(112)/8/ DATA IXDELD(112)/16/ DATA ISTARD(112)/ 134/ DATA NUMCOO(112)/8/ C C DEFINE CHARACTER 2263--LEFT ARROW C DATA IOPERA( 142),IX( 142),IY( 142)/'MOVE',-6,2/ DATA IOPERA( 143),IX( 143),IY( 143)/'DRAW',-9,0/ DATA IOPERA( 144),IX( 144),IY( 144)/'DRAW',-6,-2/ DATA IOPERA( 145),IX( 145),IY( 145)/'MOVE',-3,5/ DATA IOPERA( 146),IX( 146),IY( 146)/'DRAW',-8,0/ DATA IOPERA( 147),IX( 147),IY( 147)/'DRAW',-3,-5/ DATA IOPERA( 148),IX( 148),IY( 148)/'MOVE',-8,0/ DATA IOPERA( 149),IX( 149),IY( 149)/'DRAW',9,0/ C DATA IXMIND(113)/-13/ DATA IXMAXD(113)/13/ DATA IXDELD(113)/26/ DATA ISTARD(113)/ 142/ DATA NUMCOO(113)/8/ C C DEFINE CHARACTER 2261--RIGHT ARROW C DATA IOPERA( 150),IX( 150),IY( 150)/'MOVE',6,2/ DATA IOPERA( 151),IX( 151),IY( 151)/'DRAW',9,0/ DATA IOPERA( 152),IX( 152),IY( 152)/'DRAW',6,-2/ DATA IOPERA( 153),IX( 153),IY( 153)/'MOVE',3,5/ DATA IOPERA( 154),IX( 154),IY( 154)/'DRAW',8,0/ DATA IOPERA( 155),IX( 155),IY( 155)/'DRAW',3,-5/ DATA IOPERA( 156),IX( 156),IY( 156)/'MOVE',-9,0/ DATA IOPERA( 157),IX( 157),IY( 157)/'DRAW',8,0/ C DATA IXMIND(114)/-13/ DATA IXMAXD(114)/13/ DATA IXDELD(114)/26/ DATA ISTARD(114)/ 150/ DATA NUMCOO(114)/8/ C C DEFINE CHARACTER 804--BACK SLASH C DATA IOPERA( 158),IX( 158),IY( 158)/'MOVE',-7,12/ DATA IOPERA( 159),IX( 159),IY( 159)/'DRAW',7,-12/ C DATA IXMIND(115)/-7/ DATA IXMAXD(115)/7/ DATA IXDELD(115)/14/ DATA ISTARD(115)/ 158/ DATA NUMCOO(115)/2/ C C DEFINE CHARACTER XX--UNDERSCORE C DATA IOPERA( 160),IX( 160),IY( 160)/'MOVE',-8,-10/ DATA IOPERA( 161),IX( 161),IY( 161)/'DRAW',8,-10/ C DATA IXMIND(116)/-8/ DATA IXMAXD(116)/8/ DATA IXDELD(116)/16/ DATA ISTARD(116)/ 160/ DATA NUMCOO(116)/2/ C C DEFINE CHARACTER XXX--CUBE C DATA IOPERA( 162),IX( 162),IY( 162)/'MOVE',-6,-6/ DATA IOPERA( 163),IX( 163),IY( 163)/'DRAW',6,-6/ DATA IOPERA( 164),IX( 164),IY( 164)/'DRAW',6,6/ DATA IOPERA( 165),IX( 165),IY( 165)/'DRAW',-6,6/ DATA IOPERA( 166),IX( 166),IY( 166)/'DRAW',-6,-6/ DATA IOPERA( 167),IX( 167),IY( 167)/'MOVE',-6,6/ DATA IOPERA( 168),IX( 168),IY( 168)/'DRAW',-4,8/ DATA IOPERA( 169),IX( 169),IY( 169)/'DRAW',8,8/ DATA IOPERA( 170),IX( 170),IY( 170)/'DRAW',6,6/ DATA IOPERA( 171),IX( 171),IY( 171)/'MOVE',8,8/ DATA IOPERA( 172),IX( 172),IY( 172)/'DRAW',8,-2/ DATA IOPERA( 173),IX( 173),IY( 173)/'DRAW',6,-6/ C DATA IXMIND(117)/-6/ DATA IXMAXD(117)/8/ DATA IXDELD(117)/14/ DATA ISTARD(117)/ 162/ DATA NUMCOO(117)/12/ C C DEFINE CHARACTER XXX--PYRAMID C DATA IOPERA( 174),IX( 174),IY( 174)/'MOVE',0,8/ DATA IOPERA( 175),IX( 175),IY( 175)/'DRAW',-7,-4/ DATA IOPERA( 176),IX( 176),IY( 176)/'DRAW',7,-4/ DATA IOPERA( 177),IX( 177),IY( 177)/'DRAW',0,8/ DATA IOPERA( 178),IX( 178),IY( 178)/'DRAW',6,2/ DATA IOPERA( 179),IX( 179),IY( 179)/'DRAW',7,-4/ C DATA IXMIND(118)/-7/ DATA IXMAXD(118)/7/ DATA IXDELD(118)/14/ DATA ISTARD(118)/ 174/ DATA NUMCOO(118)/6/ C C AUGUST 1992. ADD ARROW. USE TRIANGLE COORDINATES FOR C NOW, MAY MODIFY LATER AS NEEDED (MODIFY SO THAT ARROW C COMES TO A POINT AT 0,0 SO ARROW HEAD IS AT CENTER POINT) C DEFINE CHARACTER XXX--ARROW C DATA IOPERA( 180),IX( 180),IY( 180)/'MOVE',0,0/ DATA IOPERA( 181),IX( 181),IY( 181)/'DRAW',-7,-12/ DATA IOPERA( 182),IX( 182),IY( 182)/'DRAW',7,-12/ DATA IOPERA( 183),IX( 183),IY( 183)/'DRAW',0,0/ C DATA IXMIND(119)/-7/ DATA IXMAXD(119)/7/ DATA IXDELD(119)/14/ DATA ISTARD(119)/ 180/ DATA NUMCOO(119)/4/ 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(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'MATH')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DMATH4--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHARN 52 FORMAT('ICHARN = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGG4,ISUBG4,IFOUND,IERROR 59 FORMAT('IBUGG4,ISUBG4,IFOUND,IERROR = ',A4,2X,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 C ********************************************* C ** STEP 3-- ** C ** ADJUST THE COORDINATES IF A CIRCLE. ** C ** IF THE CHARACTER IS A CIRCLE ** C ** THEN SCALE THE FIGURE DOWN FROM ** C ** -17 TO 17 TO THE MORE USUAL -7 TO 7. ** C ** THE ORIGINAL CIRCLE WAS FROM -17 TO 17 ** C ** RATHER THAN -7 TO 7 IN ** C ** ORDER TO INCREASE THE RESOLUTION ** C ** AND GIVE A 32 POINT CIRCLE RATHER ** C ** THAN A 16 POINT CIRCLE. ** C ********************************************* C IF(ICHARN.EQ.102)GOTO1210 GOTO1290 C 1210 CONTINUE AFACTO=7.0/17.0 DO1220J=1,NUMCO X(J)=X(J)*AFACTO Y(J)=Y(J)*AFACTO 1220 CONTINUE IXMINS=(-7) IXMAXS=7 IXDELS=14 C 1290 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'MATH')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DMATH4--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGG4,ISUBG4,IFOUND,IERROR 9012 FORMAT('IBUGG4,ISUBG4,IFOUND,IERROR = ',A4,2X,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 DNBRAN(N,ALPHA,BETA,ALAMB1,ALAMB2,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE DOUBLY NON-CENTRAL BETA DISTRIBUTION WITH SHAPE C PARAMETERS ALPHA AND BETA AND NON-CENTRALITY C PARAMETERS LAMBDA1 AND LAMBDA2. 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 --BETA = THE SINGLE PRECISION VALUE OF THE C SECOND SHAPE PARAMETER. C --ALAMB1 = THE SINGLE PRECISION VALUE OF THE C FIRST NON-CENTRALITY PARAMETER. C --ALAMB2 = THE SINGLE PRECISION VALUE OF THE C SECOND NON-CENTRALITY PARAMETER. 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 DOUBLY NON-CENTRAL BETA DISTRIBUTION C WITH SHAPE PARAMETER VALUES = ALPHA, BETA, ALAMB1, AND C ALAMB2. 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 AND BETA SHOULD BE POSITIVE. C --ALAMB1 AND ALAMB2 SHOULD BE NON-NEGATIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NCCRAN, CHSRAN. 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", SECOND EDITION, C 1994, PAGES 502-503. 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 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--2004.5 C ORIGINAL VERSION--MAY 2004. 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-----DATA STATEMENTS------------------------------------------------- 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('***** ERROR--THE REQUESTED NUMBER OF DOUBLY NON-CENTRAL', 1' BETA RANDOM NUMBERS IS NON-POSITIVE.') IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 16 FORMAT('***** ERROR--THE SHAPE PARAMETER ALPHA FOR THE ', 1'DOUBLY NON-CENTRAL BETA RANDOM NUMBERS IS NON-POSITIVE.') IF(BETA.LE.0.0)THEN WRITE(ICOUT,26) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 26 FORMAT('***** ERROR--THE SHAPE PARAMETER BETA FOR THE ', 1'DOUBLY NON-CENTRAL BETA RANDOM NUMBERS IS NON-POSITIVE.') IF(ALAMB1.LT.0.0)THEN WRITE(ICOUT,36) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,37) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAMB1 CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 36 FORMAT('***** ERROR--THE DOUBLY NON-CENTRALITY PARAMETER ', 1 'LAMBDA1') 37 FORMAT(' FOR THE DOUBLY NON-CENTRAL BETA RANDOM NUMBERS ', 1 'IS NEGATIVE.') IF(ALAMB2.LT.0.0)THEN WRITE(ICOUT,38) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,39) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAMB2 CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 38 FORMAT('***** ERROR--THE DOUBLY NON-CENTRALITY PARAMETER ', 1 'LAMBDA2') 39 FORMAT(' FOR THE DOUBLY NON-CENTRAL BETA RANDOM NUMBERS ', 1 'IS NEGATIVE.') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C C USE THE CENTRAL AND NON-CENTRAL CHI-SQUARE RANDOM NUMBER C ROUTINE TO GENERATE NON-CENTRAL BETA RANDOM NUMBERS. C C NCB = NCCHISQ(NU1,LAMBDA)/(NCCHISQ(NU1,LAMBDA)+NCCHISQUARE(NU2)) C ANU1=ALPHA ANU2=BETA NTEMP=1 DO100I=1,N CALL NCCRAN(NTEMP,ANU1,ALAMB1,ISEED,XTEMP) TERM1=XTEMP(1) CALL NCCRAN(NTEMP,ANU2,ALAMB2,ISEED,XTEMP) TERM2=XTEMP(1) X(I)=TERM1/(TERM1+TERM2) 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE DNFCDF(X,DF1,DF2,ALAMB1,ALAMB2,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE DOUBLY NON-CENTRAL F DISTRIBUTION C WITH REAL DEGREES OF FREEDOM C PARAMETERS = NU1 AND NU2. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X. C--------------------------------------------------------------------- C CDFDNF WRITTEN BY CHARLES P. REEVE, STATISTICAL ENGINEERING C DIVISION, NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, C MARYLAND 20899 C C FOR: COMPUTING THE CUMULATIVE DISTRIBUTION FUNCTION OF THE DOUBLY C NONCENTRAL F DISTRIBUTION TO A SPECIFIED ACCURACY (TRUNCATION C ERROR IN THE INFINITE SERIES REPRESENTATION GIVEN BY EQUATION C 2.2 IN REFERENCE 1 BELOW). THE BETA C.D.F. ROUTINE IS CALLED C AT MOST TWO TIMES. FURTHER VALUES OF THE BETA C.D.F. ARE C OBTAINED FROM RECURRENCE RELATIONS GIVEN IN REFERENCE 2. C REFERENCE 3 GIVES A DETAILED DESCRIPTION OF THE ALGORITHM C HEREIN. C C THIS PROGRAM MAY ALSO BE EFFICIENTLY USED TO COMPUTE THE C CUMULATIVE DISTRIBUTION FUNCTIONS OF THE SINGLY NONCENTRAL C AND CENTRAL F DISTRIBUTIONS BY SETTING THE APPROPRIATE C NONCENTRALITY PARAMETERS EQUAL TO ZERO. C C CHECKS ARE MADE TO ASSURE THAT ALL PASSED PARAMETERS ARE C WITHIN VALID RANGES AS GIVEN BELOW. NO UPPER LIMIT IS SET C FOR THE NONCENTRALITY PARAMETERS, BUT VALUES UP TO ABOUT C 10,000 CAN BE HANDLED WITH THE CURRENT DIMENSION LIMITS. THE C COMPUTED VALUE CDFX IS VALID ONLY IF IFLAG=0 ON RETURN. C C NOTE: IN EQUATION 2.2 OF REFERENCE 1 THE AUTHOR HAS MISTAKENLY C REVERSED THE ARGUMENTS OF THE INCOMPLETE BETA FUNCTION. C THEY SHOULD READ [(M/2)+R,(N/2+S)] WHERE M AND N ARE THE C DEGREES OF FREEDOM ASSOCIATED WITH THE NUMERATOR AND C DENOMINATOR RESPECTIVELY OF THE F STATISTIC. TO FURTHER C CONFUSE THE ISSUE, THE AUTHOR HAS REVERSED THE USAGE OF C M AND N IN SECTION 1 OF THE PAPER. C C NOTE: IN SUBROUTINE EDGEF THE DOUBLE PRECISION CONSTANT DEUFLO IS C THE EXPONENTIAL UNDERFLOW LIMIT WHOSE CURRENT VALUE IS SET C AT -69D0. ON A COMPUTER WHERE DEXP(-69D0) CAUSES UNDERFLOW C THIS LIMIT SHOULD BE CHANGED. C C SUBPROGRAMS CALLED: CDFBET (BETA C.D.F.) C DGAMLN (DOUBLE PRECISION LOG OF GAMMA FUNCTION) C POISSF, EDGEF (ATTACHED) C C CURRENT VERSION COMPLETED SEPTEMBER 29, 1988 C C REFERENCES: C C 1. BULGREN, W.G., 'ON REPRESENTATIONS OF THE DOUBLY NONCENTRAL F C DISTRIBUTION', JOURNAL OF THE AMERICAN STATISTICAL ASSOCIATION, C MARCH 1971, VOLUME 66, NO. 333, PP. 184-186. C C 2. ABRAMOWITZ, MILTON, AND STEGUN, IRENE A., 'HANDBOOK OF C MATHEMATICAL FUNCTIONS', NATIONAL BUREAU OF STANDARDS APPLIED C MATHEMATICS SERIES 55, NOVEMBER 1970, P. 944. C C 3. REEVE, CHARLES P., 'AN ALGORITHM FOR COMPUTING THE DOUBLY C NONCENTRAL F C.D.F. TO A SPECIFIED ACCURACY', STATISTICAL C ENGINEERING DIVISION NOTE 86-4, NOVEMBER 1986. C--------------------------------------------------------------------- C DEFINITION OF PASSED PARAMETERS: C C * X = VALUE (>=0) AT WHICH THE C.D.F. IS TO BE COMPUTED (REAL) C C * DF1 = DEGREES OF FREEDOM (>0) IN THE NUMERATOR (REAL) C C * DF2 = DEGREES OF FREEDOM (>0) IN THE DENOMINATOR (REAL) C C * ALAMB1 = THE NONCENTRALITY PARAMETER (>=0) FOR THE NUMERATOR C (REAL) [EQUAL TO ZERO FOR THE CENTRAL F DISTRIBUTION] C C * ALAMB2 = THE NONCENTRALITY PARAMETER (>=0) FOR THE DENOMINATOR C (REAL) [EQUAL TO ZERO FOR THE SINGLY NONCENTRAL F AND C CENTRAL F DISTRIBUTIONS] C C * EPS = THE DESIRED ABSOLUTE ACCURACY OF THE C.D.F. (REAL) C [1 >= EPS >= 10**(-10)] C C IFLAG = ERROR INDICATOR ON OUTPUT (INTEGER) INTERPRETATION: C 0 -> NO ERRORS DETECTED C 1,2 -> ERROR FLAGS FROM SUBROUTINE CDFBET C 3 -> EITHER ALAMB1 OR ALAMB2 IS < 0 C 4 -> EITHER DF1 OR DF2 IS <= 0 C 5 -> EPS IS OUTSIDE THE RANGE [10**(-10),1] C 6 -> VECTOR DIMENSIONS ARE TOO SMALL - INCREASE NX C C CDFX = THE DOUBLY NONCENTRAL F C.D.F. EVALUATED AT X (REAL) C C * INDICATES PARAMETERS REQUIRING INPUT VALUES C--------------------------------------------------------------------- C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--94/9 C ORIGINAL VERSION--SEPTEMBER 1994. C PARAMETER (NX=1000) DIMENSION BFI(NX),BFJ(NX),POI(NX),POJ(NX) 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 C CHECK THE INPUT ARGUMENTS FOR ERRORS C CDF=0.0 IF(DF1.LE.0.0)GOTO50 IF(DF2.LE.0.0)GOTO55 IF(X.LT.0.0)GOTO60 IF(ALAMB1.LT.0.0)GOTO70 IF(ALAMB2.LT.0.0)GOTO80 IF(ALAMB1.GT.10000.0)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAMB1 CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 301 FORMAT('**** FATAL DIAGNOSTIC--THE FIRST NON-CENTRALITY ', * 'PARAMETER HAS A VALUE GREATER THAN 10000.') IF(ALAMB2.GT.10000.0)THEN WRITE(ICOUT,303) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAMB2 CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 303 FORMAT('**** FATAL DIAGNOSTIC--THE SECOND NON-CENTRALITY ', * 'PARAMETER HAS A VALUE GREATER THAN 10000.') GOTO90 50 WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)DF1 CALL DPWRST('XXX','BUG ') CDF=0.0 RETURN 55 WRITE(ICOUT,23) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)DF2 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 70 WRITE(ICOUT,24) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAMB1 CALL DPWRST('XXX','BUG ') CDF=0.0 RETURN 80 WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAMB2 CALL DPWRST('XXX','BUG ') CDF=0.0 RETURN 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ', 1'TO THE DNFCDF SUBROUTINE IS NEGATIVE *****') 15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1'DNFCDF SUBROUTINE IS NON-POSITIVE *****') 23 FORMAT('***** FATAL ERROR--THE 3RD INPUT ARGUMENT TO THE ', 1'DNFCDF SUBROUTINE IS NON-POSITIVE *****') 24 FORMAT('***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE ', 1'DNFCDF SUBROUTINE IS NEGATIVE *****') 25 FORMAT('***** FATAL ERROR--THE FIFTH INPUT ARGUMENT TO THE ', 1'DNFCDF SUBROUTINE IS NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C 90 CONTINUE C CCCCC MAY 2004. INCREASE ERROR CRITIERION. CCCCC EPS=1.0E-5 EPS=1.0E-6 C C--- SET ERROR CRITERION FOR THE BETA C.D.F. (PECULIAR TO CDFBET) C EPS3 = 0.001*EPS C FA = 0.5*ALAMB1 GA = 0.5*ALAMB2 FB = 0.5*DF1 GB = 0.5*DF2 YY = DF2/(DF2+DF1*X) IF (YY.GE.1.0) GOTO9999 XX = 1.0-YY IF (XX.GE.1.0) THEN CDF = 1.0 GOTO9999 ENDIF C C--- COMPUTE POISSON PROBABILITIES IN VECTORS POI AND POJ C IFLAG=0 CALL POISSF(FA,EPS,IMIN,NI,POI,NX,IFLAG) IF (IFLAG.NE.0) THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('*****ERROR FROM DNFCDF--ERROR CONDITION RETURNED FROM ', * 'THE POISSF ROUTINE. ****') FC = FB+REAL(IMIN) CALL POISSF (GA,EPS,JMIN,NJ,POJ,NX,IFLAG) IF (IFLAG.NE.0) THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF GC = GB+REAL(JMIN) C C--- COMPUTE BETA C.D.F. BY RECURRENCE WHEN I=IMIN AND J=JMIN TO JMAX C CALL EDGEF(NJ,GC,FC,YY,XX,BFJ,CDF,POJ,POI,EPS3,IFLAG,1) IF (NI.LE.1.OR.IFLAG.NE.0)THEN GOTO9999 ENDIF C C--- COMPUTE BETA C.D.F. BY RECURRENCE WHEN J=JMIN AND I=IMIN TO IMAX C BFI(1) = BFJ(1) CALL EDGEF (NI,FC,GC,XX,YY,BFI,CDF,POI,POJ,EPS3,IFLAG,2) IF (NJ.LE.1.OR.IFLAG.NE.0)THEN GOTO9999 ENDIF C C--- COMPUTE BETA C.D.F. BY RECURRENCE WHEN I>IMIN AND J>JMIN C DO120 I = 2, NI BFJ(1) = BFI(I) DO110 J = 2, NJ BFJ(J) = XX*BFJ(J)+YY*BFJ(J-1) CDF = CDF+POI(I)*POJ(J)*BFJ(J) 110 CONTINUE 120 CONTINUE C 9999 CONTINUE RETURN C END REAL FUNCTION DNFFU3(X) C C PURPOSE--DNTPDF CALLS DIFF TO FIND A NUMERICAL DERIVATIVE FOR C THE DOUBLY NON-CENTRAL CUMULATIVE DISTRIBUTION C FUNCTION. DNFFU3 IS A FUNCTION THAT CALL DNFCDF. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE DERIVATIVE C IS TO BE EVALUATED. C OUTPUT--THE SINGLE PRECISION FUNCTION VALUE DNFFU3. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DNFCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) 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 NATION 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--2004.5 C ORIGINAL VERSION--MAY 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL ANU1 REAL ANU2 REAL ALAMB1 REAL ALAMB2 COMMON/DNFCOM/ANU1,ANU2,ALAMB1,ALAMB2 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 CALL DNFCDF(X,ANU1,ANU2,ALAMB1,ALAMB2,CDF) DNFFU3=CDF C 9999 CONTINUE RETURN END SUBROUTINE DNFPDF(X,NU1,NU2,LAMBD1,LAMBD2,PDF) C C PURPOSE--PROBABILITY DENSITY FUNCTION FOR THE DOUBLY NON-CENTRAL C F DISTRIBUTION. THE PROBABILITY DENSITY FUNCTION C IS COMPUTED BY COMPUTING THE NUMERICAL DERIVATIVE OF C THE CUMULATIVE DISTRIBUTION FUNCTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C --NU1 = THE FIRST DEGREES OF FREEDOM PARAMETER C --NU2 = THE SECOND DEGREES OF FREEDOM PARAMETER C --LAMB1 = THE FIRST NON-CENTRALITY PARAMETER C --LAMB2 = THE SECOND NON-CENTRALITY PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY FUNCTION VALUE PDF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DIFF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) 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/5 C ORIGINAL VERSION--MAY 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C REAL X REAL NU1 REAL NU2 REAL LAMBD1 REAL LAMBD2 REAL PDF C REAL DNFFU3 EXTERNAL DNFFU3 REAL ANU1 REAL ANU2 REAL ALAMB1 REAL ALAMB2 COMMON/DNFCOM/ANU1,ANU2,ALAMB1,ALAMB2 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 PDF=0.0 C IF(NU1.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102)NU1 CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('**** ERROR--THE FIRST DEGREES OF FREEDOM PARAMETER') 102 FORMAT(' FOR DNFPDF IS NON-POSITIVE. IT HAS THE VALUE ', 1 E15.7) C IF(NU2.LE.0.0)THEN WRITE(ICOUT,103) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)NU2 CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 103 FORMAT('**** ERROR--THE SECOND DEGREES OF FREEDOM PARAMETER') 104 FORMAT(' FOR DNFPDF IS NON-POSITIVE. IT HAS THE VALUE ', 1 E15.7) C IF(LAMBD1.LT.0.0)THEN WRITE(ICOUT,303) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,304)LAMBD1 CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 303 FORMAT('**** ERROR--THE FIRST NON-CENTRALITY PARAMETER IS ', 1 'NEGATIVE.') 304 FORMAT(' IT HAS THE VALUE ',E15.7) C IF(LAMBD2.LT.0.0)THEN WRITE(ICOUT,305) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,306)LAMBD2 CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 305 FORMAT('**** ERROR--THE SECOND NON-CENTRALITY PARAMETER IS ', 1 'NEGATIVE.') 306 FORMAT(' IT HAS THE VALUE ',E15.7) C C FIND NUMERIC DERIVATIVE OF CDF ROUTINE C IORD=1 EPS=0.001 ACCUR=0.0 IFAIL=0 X0 = X XMIN=MAX(X0 - 5.0,0.0) XMAX=X0 + 5.0 ANU1=NU1 ANU2=NU2 ALAMB1=LAMBD1 ALAMB2=LAMBD2 C CALL DIFF(IORD,X0,XMIN,XMAX,DNFFU3,EPS,ACCUR,PDF,ERROR,IFAIL) C IF(IFAIL.EQ.1)THEN 999 FORMAT(1X) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,401) 401 FORMAT('***** WARNING IN NUMERICAL DERIVATIVE FOR DNFPDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,403) 403 FORMAT(' THE ESTIMATED ERROR IN THE RESULT EXCEEDS THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,405) 405 FORMAT(' REQUESTED ERROR, BUT THE MOST ACCURATE RESULT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,407) 407 FORMAT(' POSSIBLE HAS BEEN RETURNED.') CALL DPWRST('XXX','BUG ') ELSEIF(IFAIL.EQ.2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,411) 411 FORMAT('***** ERROR IN NUMERICAL DERIVATIVE FOR DNFPDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,413) 413 FORMAT(' ERROR IN THE INPUT TO THE DIFF ROUTINE.') CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ELSEIF(IFAIL.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,421) 421 FORMAT('***** ERROR IN NUMERICAL DERIVATIVE FOR DNFPDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,423) 423 FORMAT(' THE INTERVAL FOR DIFFERENTIATION, (',G15.7, 1 ',',G15.7,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,425) 425 FORMAT(' IS TOO SMALL.') CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF C 9999 CONTINUE RETURN END SUBROUTINE DNFPPF(P,DF1,DF2,ALAMB1,ALAMB2,PPF) C C PURPOSE --PERCENT POINT FUNCTION FOR THE DOUBLY NON-CENTRAL F 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--94/9 C ORIGINAL VERSION--SEPTEMBER 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 DATA EPS /0.000001/ DATA SIG /1.0E-6/ DATA ZERO /0./ DATA MAXIT /1000/ 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(DF1.LT.0.0)GOTO55 IF(DF2.LT.0.0)GOTO65 IF(ALAMB1.LT.0.0)GOTO70 IF(ALAMB2.LT.0.0)GOTO80 IF(ALAMB1.GT.10000.0)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAMB1 CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 301 FORMAT('**** FATAL DIAGNOSTIC--THE FIRST NON-CENTRALITY ', * 'PARAMETER HAS A VALUE GREATER THAN 10000.') IF(ALAMB2.GT.10000.0)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAMB2 CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 302 FORMAT('**** FATAL DIAGNOSTIC--THE SECOND NON-CENTRALITY ', * 'PARAMETER HAS A VALUE GREATER THAN 10000.') GOTO90 50 WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 55 WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)NU1 CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 65 WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)NU2 CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 70 WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAMB1 CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 80 WRITE(ICOUT,45) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAMB2 CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 C 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1' DNFPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 11 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1' DNFPPF SUBROUTINE IS NON-POSITIVE.') 12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' DNFPPF SUBROUTINE IS NON-POSITIVE.') 35 FORMAT('***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE ', 1' DNFPPF SUBROUTINE IS NEGATIVE *****') 45 FORMAT('***** FATAL ERROR--THE FIFTH INPUT ARGUMENT TO THE ', 1' DNFPPF SUBROUTINE IS NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I15,' *****') C 90 CONTINUE C C FIND BRACKETING INTERVAL. USE CORRESPONDING CENTRAL F C AS INITIAL GUESS, INCREMENTS OF 100 AROUND IT. C AFTER SUCCESSFULLY FIND BRACKETING INTERVAL, THEN SWITCH TO C MORE EFFICIENT BISECTION METHOD. C XINC=5.0 NU1=DF1+0.5 NU2=DF2+0.5 CALL FPPF(P,NU1,NU2,XL) ICOUNT=0 MAXCNT=10000 C 91 CONTINUE XR=XL+XINC IF(XL.LE.0.0)XL=0.0 IF(XR.LE.0.0)XR=XL+1.0 CALL DNFCDF(XL,DF1,DF2,ALAMB1,ALAMB1,CDFL) CALL DNFCDF(XR,DF1,DF2,ALAMB1,ALAMB2,CDFR) IF(CDFL.LT.P .AND. CDFR.LT.P)THEN XL=XR ELSEIF(CDFL.GT.P .AND. CDFR.GT.P)THEN XR=XL 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--DNFPPF 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 DNFCDF(X,DF1,DF2,ALAMB1,ALAMB2,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--DNFPPF ROUTINE DID NOT CONVERGE. ***') GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE DNFRAN(N,ANU1,ANU2,ALAMB1,ALAMB2,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE DOUBLY NON-CENTRAL F DISTRIBUTION WITH SHAPE C PARAMETERS ANU1 AND ANU2 AND NON-CENTRALITY C PARAMETERS LAMBDA1 AND LAMBDA2. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ANU1 = THE SINGLE PRECISION VALUE OF THE C FIRST SHAPE PARAMETER. C --ANU2 = THE SINGLE PRECISION VALUE OF THE C SECOND SHAPE PARAMETER. C --ALAMB1 = THE SINGLE PRECISION VALUE OF THE C FIRST NON-CENTRALITY PARAMETER. C --ALAMB2 = THE SINGLE PRECISION VALUE OF THE C SECOND NON-CENTRALITY PARAMETER. 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 DOUBLY NON-CENTRAL F DISTRIBUTION C WITH SHAPE PARAMETER VALUES = ANU1, ANU2, ALAMB1, AND C ALAMB2. 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 --ANU1 AND ANU2 SHOULD BE POSITIVE. C --ALAMB1 AND ALAMB2 SHOULD BE NON-NEGATIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NORRAN, CHSRAN. 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", SECOND EDITION, C 1994, PAGES 502-503. 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 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--2004.5 C ORIGINAL VERSION--MAY 2004. 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-----DATA STATEMENTS------------------------------------------------- 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('***** ERROR--THE REQUESTED NUMBER OF DOUBLY ', 1'NON-CENTRAL F RANDOM NUMBERS IS NON-POSITIVE.') IF(ANU1.LE.0.0)THEN WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ANU1 CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 16 FORMAT('***** ERROR--THE SHAPE PARAMETER NU1 FOR THE ', 1'DOUBLY NON-CENTRAL F RANDOM NUMBERS IS NON-POSITIVE.') IF(ANU2.LE.0.0)THEN WRITE(ICOUT,26) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ANU2 CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 26 FORMAT('***** ERROR--THE SHAPE PARAMETER NU2 FOR THE ', 1'DOUBLY NON-CENTRAL F RANDOM NUMBERS IS NON-POSITIVE.') IF(ALAMB1.LT.0.0)THEN WRITE(ICOUT,36) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAMB1 CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 36 FORMAT('***** ERROR--THE NON-CENTRALITY PARAMETER LAMBDA1 FOR ', 1'THE DOUBLY NON-CENTRAL F RANDOM NUMBERS IS NEGATIVE.') C IF(ALAMB2.LT.0.0)THEN WRITE(ICOUT,38) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALAMB2 CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 38 FORMAT('***** ERROR--THE NON-CENTRALITY PARAMETER LAMBDA2 FOR ', 1'THE DOUBLY NON-CENTRAL F RANDOM NUMBERS IS NEGATIVE.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C C IF DEGREES OF FREEDOM ARE LESS THAN 1, THEN USE PERCENT C POINT METHOD (PROBABLY NOT MOST EFFICIENT METHOD, BUT LEAVE C UNTIL FIND A BETTER ALGORITHM). C IF(ANU1.LE.1.0 .OR. ANU2.LE.1.0)THEN CALL UNIRAN(N,ISEED,X) DO1378II=1,N ATEMP=X(II) CALL DNFPPF(ATEMP,ANU1,ANU2,ALAMB1,ALAMB2,PPF) X(II)=PPF 1378 CONTINUE ELSE NTEMP=1 DO100II=1,N CALL NORRAN(NTEMP,ISEED,XTEMP) X1=(XTEMP(1) + SQRT(ALAMB1))**2 IF(ANU1.GT.1.0)THEN CALL CHSRAN(NTEMP,ANU1-1.0,ISEED,XTEMP) X1=X1+XTEMP(1) ENDIF CALL NORRAN(NTEMP,ISEED,XTEMP) X2=(XTEMP(1) + SQRT(ALAMB2))**2 IF(ANU2.GT.1.0)THEN CALL CHSRAN(NTEMP,ANU2-1.0,ISEED,XTEMP) X2=X2+XTEMP(1) ENDIF X(II)=ANU2*X1/(ANU1*X2) 100 CONTINUE ENDIF C 9000 CONTINUE RETURN END SUBROUTINE DNTCDF(X, DF, DELTA, ALAMB, CDF) CCCCC CONVERT TO DOUBLE PRECISION. SINGLE PRECISION GIVES INACCURATE CCCCC RESULTS ON A 32-BIT COMPUTER. C C-------------------------------------------------------------------- C CDFDNT WRITTEN BY CHARLES P. REEVE, STATISTICAL ENGINEERING C DIVISION, NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, C MARYLAND 20899 C C FOR: COMPUTING THE CUMULATIVE DISTRIBUTION FUNCTION OF THE DOUBLY C NONCENTRAL T DISTRIBUTION TO A SPECIFIED ACCURACY (TRUNCATION C ERROR IN THE INFINITE SERIES REPRESENTATION GIVEN BY EQUATION C 4 IN REFERENCE 1 BELOW). WHEN X<0 THE C.D.F. IS COMPUTED C FROM CDF(X,DF,DELTA,ALAMB) = 1 - CDF(-X,DF,-DELTA,ALAMB). C THE BETA C.D.F. ROUTINE IS CALLED AT MOST FOUR TIMES. FURTHER C VALUES OF THE BETA C.D.F. ARE OBTAINED FROM RECURRENCE C RELATIONS GIVEN IN REFERENCE 2. REFERENCE 3 GIVES A DETAILED C DESCRIPTION OF THE ALGORITHM HEREIN. C C THIS PROGRAM MAY ALSO BE EFFICIENTLY USED TO COMPUTE THE C CUMULATIVE DISTRIBUTION FUNCTIONS OF THE SINGLY NONCENTRAL C AND CENTRAL T DISTRIBUTIONS BY SETTING THE APPROPRIATE C NONCENTRALITY PARAMETERS EQUAL TO ZERO. C C CHECKS ARE MADE TO ASSURE THAT ALL PASSED PARAMETERS ARE C WITHIN VALID RANGES AS GIVEN BELOW. NO UPPER LIMIT IS SET C FOR THE NONCENTRALITY PARAMETERS, BUT VALUES UP TO ABOUT 100 C FOR DELTA AND 10,000 FOR LAMBDA CAN BE HANDLED WITH THE C CURRENT DIMENSION LIMITS. THE COMPUTED VALUE CDF IS VALID C ONLY IF IFLAG=0 ON RETURN. C C NOTE: IN SUBROUTINE EDGET THE DOUBLE PRECISION CONSTANT DEUFLO IS C THE EXPONENTIAL UNDERFLOW LIMIT WHOSE CURRENT VALUE IS SET C AT -69D0. ON A COMPUTER WHERE DEXP(-69D0) CAUSES UNDERFLOW C THIS LIMIT SHOULD BE CHANGED. C C SUBPROGRAMS CALLED: BETCDF (BETA C.D.F.) C DLNGAM (DOUBLE PRECISION LOG OF GAMMA FUNCTION) C POISST, EDGET, GRID C C CURRENT VERSION COMPLETED SEPTEMBER 29, 1988 C C REFERENCES: C C 1. KRISHNAN, MARAKATHA, 'SERIES REPRESENTATIONS OF THE DOUBLY C NONCENTRAL T DISTRIBUTION', JOURNAL OF THE AMERICAN STATISTICAL C ASSOCIATION, SEPTEMBER 1968, VOLUME 63, NO. 323, PP. 1004-1012. C C 2. ABRAMOWITZ, MILTON, AND STEGUN, IRENE A., 'HANDBOOK OF C MATHEMATICAL FUNCTIONS', NATIONAL BUREAU OF STANDARDS APPLIED C MATHEMATICS SERIES 55, NOVEMBER 1970, P. 944. C C 3. REEVE, CHARLES P., 'AN ALGORITHM FOR COMPUTING THE DOUBLY C NONCENTRAL T C.D.F. TO A SPECIFIED ACCURACY', STATISTICAL C ENGINEERING DIVISION NOTE 86-5, DECEMBER 1986. C-------------------------------------------------------------------- C DEFINITION OF PASSED PARAMETERS: C C * X = VALUE AT WHICH THE C.D.F. IS TO BE COMPUTED (REAL) C C * DF = DEGREES OF FREEDOM (>0) IN THE DENOMINATOR (REAL) C C * DELTA = THE NONCENTRALITY PARAMETER FOR THE NUMERATOR (REAL) C [EQUAL TO ZERO FOR THE CENTRAL T DISTRIBUTION] C C * ALAMB = THE NONCENTRALITY PARAMETER (>=0) FOR THE DENOMINATOR C (REAL) [EQUAL TO ZERO FOR THE SINGLY NONCENTRAL T AND C CENTRAL T DISTRIBUTIONS] C C * EPS = THE DESIRED ABSOLUTE ACCURACY OF THE C.D.F. (REAL) C [1 >= EPS >= 10**(-10)] C (NOTE: WE WILL HARD CODE THIS TO 1.0E-6) C C CDF = THE DOUBLY NONCENTRAL T C.D.F. EVALUATED AT X (REAL) C C * INDICATES PARAMETERS REQUIRING INPUT VALUES C-------------------------------------------------------------------- C IMPLICIT DOUBLE PRECISION (A-H,O-Z) REAL X, DF, DELTA, ALAMB, CDF C PARAMETER (NX=1000) DIMENSION BFI(NX),BFJ(NX),POI(NX),POJ(NX) CCCCC DOUBLE PRECISION DARG,DFA LOGICAL LL C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C REAL CPUMIN,CPUMAX COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C CCCCC MAY 2004. INCREASE ACCURACY CCCCC DATA EPS/1.D-06/ DATA EPS/1.D-08/ C DCDF=0.D0 IF(DF.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102)DF CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('**** FATAL DIAGNOSTIC--THE DEGREES OF FREEDOM PARAMETER') 102 FORMAT(' IS NON-POSITIVE. IT HAS THE VALUE ',E15.7) IF(ABS(DELTA).GT.100.0)THEN WRITE(ICOUT,201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,202)DELTA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 201 FORMAT('**** FATAL DIAGNOSTIC--THE FIRST NON-CENTRALITY ', * 'PARAMETER HAS AN ABSOLUTE VALUE GREATER THAN 100.') 202 FORMAT(' IT HAS THE VALUE ',E15.7) IF(ALAMB.GT.10000.0)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,302)ALAMB CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 301 FORMAT('**** FATAL DIAGNOSTIC--THE SECOND NON-CENTRALITY ', * 'PARAMETER HAS A VALUE GREATER THAN 10000.') 302 FORMAT(' IT HAS THE VALUE ',E15.7) IF(ALAMB.LT.0.0)THEN WRITE(ICOUT,303) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,304)ALAMB CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 303 FORMAT('**** FATAL DIAGNOSTIC--THE SECOND NON-CENTRALITY ', * 'PARAMETER IS NEGATIVE.') 304 FORMAT(' IT HAS THE VALUE ',E15.7) C IFLAG=0 CDF=0.0 EPS3 = 0.001*EPS C DX=DBLE(X) DDF=DBLE(DF) DLAMB=DBLE(ALAMB) DDELTA=DBLE(DELTA) DCDF=0.0D0 C DELSQ = DDELTA**2 FA = 0.5D0*DELSQ GA = 0.5D0*DLAMB GB = 0.5D0*DDF YY = DDF/(DDF+DX*DX) XX = 1.0D0-YY C C--- IF X<0 SET LL=.TRUE., REVERSE SIGN OF DELTA, AND USE THE C--- IDENTITY DESCRIBED UP FRONT FOR COMPUTING THE C.D.F. C LL = X.LT.0.0D0 IF (XX.GE.1.0D0) THEN DCDF = 1.0D0 GO TO 50 ENDIF SDELTA = DDELTA IF (LL) SDELTA = -DDELTA C C--- COMPUTE POISSON PROBABILITIES IN VECTOR POI C CALL POISST(FA,EPS,IMIN,NI,POI,NX,IFLAG) IF (IFLAG.NE.0) THEN WRITE(ICOUT,501) CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF CCCCC IF (IFLAG.NE.0) RETURN IF (YY.GE.1.0D0) GO TO 10 FC = 0.5D0+DBLE(IMIN) C C--- COMPUTE POISSON PROBABILITIES IN VECTOR POJ C CALL POISST (GA,EPS,JMIN,NJ,POJ,NX,IFLAG) CCCCC IF (IFLAG.NE.0) RETURN IF (IFLAG.NE.0) THEN WRITE(ICOUT,501) CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 501 FORMAT('**** FATAL DIAGNOSTIC--DNTCDF ROUTINE RETURNED AN ', 1 'ERROR FROM THE POISST ROUTINE. ***') GC = GB+DBLE(JMIN) C C--- SUM THE TERMS CORRESPONDING TO 'EVEN' VALUES OF INDEX I C CALL GRIDD(NI,NJ,FC,GC,BFI,BFJ,POI,POJ,XX,YY,EPS3,DCDF,IFLAG) CCCCC IF (IFLAG.NE.0) RETURN IF (IFLAG.NE.0) THEN WRITE(ICOUT,401) CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 401 FORMAT('**** FATAL DIAGNOSTIC--DNTCDF ROUTINE RETURNED AN ', 1 'FROM THE GRID ROUTINE. ***') 10 IF (DDELTA.EQ.0.0D0) THEN NI = 0 SUM = 0.0D0 IF (YY.GE.1.0D0) GO TO 40 ELSE C C--- COMPUTE 'POISSON-LIKE' PROBABILITIES IN VECTOR POI C K = INT(FA) IF (IMIN.GT.0) THEN IMIN = IMIN-1 NI = NI+1 ENDIF DFA = FA DARG = (DBLE(K)+0.5D0)*DLOG(DFA)-DFA-DLNGAM(DBLE(K)+1.5D0) L = K-IMIN+1 POI(L) = DSIGN(DEXP(DARG),SDELTA) SUM = POI(L) DO 20 I = K-1, IMIN, -1 L = L-1 POI(L) = POI(L+1)*(DBLE(I)+1.5D0)/FA SUM = SUM+POI(L) 20 CONTINUE L = K-IMIN+1 DO 30 I = K+1, IMIN+NI-1 L = L+1 POI(L) = POI(L-1)*FA/(DBLE(I)+0.5D0) SUM = SUM+POI(L) 30 CONTINUE IF (YY.GE.1.0D0) GO TO 40 FC = 1.0D0+DBLE(IMIN) C C--- SUM THE TERMS CORRESPONDING TO 'ODD' VALUES OF INDEX I C CALL GRIDD(NI,NJ,FC,GC,BFI,BFJ,POI,POJ,XX,YY,EPS3,DCDF,IFLAG) CCCCC IF (IFLAG.NE.0) RETURN IF (IFLAG.NE.0) THEN WRITE(ICOUT,401) CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF ENDIF C C--- COMPUTE THE NORMAL C.D.F. AT -SDELTA C 40 PHI = 0.5D0*(1.0D0-SUM) C C--- COMPUTE THE DOUBLY NONCENTRAL T C.D.F. AT X, USING AN IDENTITY C--- IF X<0 C DCDF = 0.5D0*DCDF+PHI 50 IF (LL) DCDF = 1.0D0-DCDF C 9999 CONTINUE CDF=SNGL(DCDF) RETURN END REAL FUNCTION DNTFU3(X) C C PURPOSE--DNTPDF CALLS DIFF TO FIND A NUMERICAL DERIVATIVE C FOR THE NON-CENTRAL CUMULATIVE DISTRIBUTION FUNCTION. C DNTFU3 IS A FUNCTION THAT CALL DNTCDF. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE DERIVATIVE C IS TO BE EVALUATED. C OUTPUT--THE SINGLE PRECISION FUNCTION VALUE DNTFU3. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NCBCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION 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 NATION 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--2004.3 C ORIGINAL VERSION--APRIL 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL ANU REAL DELTA REAL ALAMB COMMON/DNTCOM/ANU,DELTA,ALAMB 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 CALL DNTCDF(X,ANU,DELTA,ALAMB,CDF) DNTFU3=CDF C 9999 CONTINUE RETURN END SUBROUTINE DNTPDF(X, ANU, DELTA, LAMBDA, PDF) C C PURPOSE--PROBABILITY DENSITY FUNCTION FOR THE NON-CENTRAL C T DISTRIBUTION. THE PROBABILITY DENSITY FUNCTION C IS COMPUTED BY COMPUTING THE NUMERICAL DERIVATIVE OF C THE CUMULATIVE DISTRIBUTION FUNCTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C --ANU = THE DEGREES OF FREEDOM SHAPE PARAMETER C --DELTA = THE FIRST NON-CENTRALITY SHAPE PARAMETER C --LAMBDA = THE SECOND NON-CENTRALITY PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY FUNCTION VALUE PDF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DIFF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) 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/5 C ORIGINAL VERSION--MAY 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C REAL X REAL ANU REAL DELTA REAL LAMBDA REAL PDF C REAL DNTFU3 EXTERNAL DNTFU3 REAL ANU2 REAL DELTA2 REAL ALAMB COMMON/DNTCOM/ANU2,DELTA2,ALAMB 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 PDF=0.0 C IF(ANU.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102)ANU CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('**** ERROR--THE DEGREES OF FREEDOM PARAMETER') 102 FORMAT(' IS NON-POSITIVE. IT HAS THE VALUE ',E15.7) IF(ABS(DELTA).GT.100.0)THEN WRITE(ICOUT,201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,202)DELTA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 201 FORMAT('**** ERROR--THE FIRST NON-CENTRALITY ', * 'PARAMETER HAS AN ABSOLUTE VALUE GREATER THAN 100.') 202 FORMAT(' IT HAS THE VALUE ',E15.7) IF(ALAMB.GT.10000.0)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,302)ALAMB CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 301 FORMAT('**** ERROR--THE SECOND NON-CENTRALITY ', * 'PARAMETER HAS A VALUE GREATER THAN 10000.') 302 FORMAT(' IT HAS THE VALUE ',E15.7) IF(ALAMB.LT.0.0)THEN WRITE(ICOUT,303) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,304)ALAMB CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 303 FORMAT('**** ERROR--THE SECOND NON-CENTRALITY ', * 'PARAMETER IS NEGATIVE.') 304 FORMAT(' IT HAS THE VALUE ',E15.7) C C C FIND NUMERIC DERIVATIVE OF CDF ROUTINE C IORD=1 EPS=0.0001 ACCUR=0.0 IFAIL=0 X0 = X XMIN=X0 - 50.0 XMAX=X0 + 50.0 ANU2=ANU DELTA2=DELTA ALAMB=LAMBDA C CALL DIFF(IORD,X0,XMIN,XMAX,DNTFU3,EPS,ACCUR,PDF,ERROR,IFAIL) C IF(IFAIL.EQ.1)THEN 999 FORMAT(1X) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,401) 401 FORMAT('***** WARNING IN NUMERICAL DERIVATIVE FOR DNTPDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,403) 403 FORMAT(' THE ESTIMATED ERROR IN THE RESULT EXCEEDS THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,405) 405 FORMAT(' REQUESTED ERROR, BUT THE MOST ACCURATE RESULT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,407) 407 FORMAT(' POSSIBLE HAS BEEN RETURNED.') CALL DPWRST('XXX','BUG ') ELSEIF(IFAIL.EQ.2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,411) 411 FORMAT('***** ERROR IN NUMERICAL DERIVATIVE FOR DNTPDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,413) 413 FORMAT(' ERROR IN THE INPUT TO THE DIFF ROUTINE.') CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ELSEIF(IFAIL.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,421) 421 FORMAT('***** ERROR IN NUMERICAL DERIVATIVE FOR DNTPDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,423) 423 FORMAT(' THE INTERVAL FOR DIFFERENTIATION, (',G15.7, 1 ',',G15.7,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,425) 425 FORMAT(' IS TOO SMALL.') CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF C 9999 CONTINUE RETURN END SUBROUTINE DNTPPF(P,NU,DELTA,ALAMB,PPF) C C PURPOSE --PERCENT POINT FUNCTION FOR THE DOUBLY NON-CENTRAL T 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--94/9 C ORIGINAL VERSION--SEPTEMBER 1994. C UPDATED --OCTOBER 2006. CALL LIST TO TPPF C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C REAL DELTA, ALAMB REAL NU 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 DATA EPS /0.0001/ DATA SIG /1.0E-5/ DATA ZERO /0./ DATA MAXIT /500/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C PPF=0.0 IF(P.LE.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1' DNTPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.') IF(NU.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102)NU CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('**** FATAL DIAGNOSTIC--THE DEGREES OF FREEDOM PARAMETER') 102 FORMAT(' IS NON-POSITIVE. IT HAS THE VALUE ',E15.7) IF(ABS(DELTA).GT.100.0)THEN WRITE(ICOUT,201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,202)DELTA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 201 FORMAT('**** FATAL DIAGNOSTIC--THE FIRST NON-CENTRALITY ', * 'PARAMETER HAS AN ABSOLUTE VALUE GREATER THAN 100.') 202 FORMAT(' IT HAS THE VALUE ',E15.7) IF(ABS(ALAMB).GT.10000.0)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,302)ALAMB CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 301 FORMAT('**** FATAL DIAGNOSTIC--THE SECOND NON-CENTRALITY ', * 'PARAMETER HAS AN ABSOLUTE VALUE GREATER THAN 10000.') 302 FORMAT(' IT HAS THE VALUE ',E15.7) C C FIND BRACKETING INTERVAL. USE CORRESPONDING CENTRAL CHI-SQUARE C AS INITIAL GUESS, INCREMENTS OF 100 AROUND IT. C AFTER SUCCESSFULLY FIND BRACKETING INTERVAL, THEN SWITCH TO C MORE EFFICIENT BISECTION METHOD. C NUINT=NU+0.5 CALL TPPF(P,REAL(NUINT),XL) XINC=20.0 ICOUNT=0 MAXCNT=10000 C 91 CONTINUE XR=XL+XINC CALL DNTCDF(XL,NU,DELTA,ALAMB,CDFL) CALL DNTCDF(XR,NU,DELTA,ALAMB,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--DNTPPF 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 DNTCDF(X,NU,DELTA,ALAMB,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--DNTPPF ROUTINE DID NOT CONVERGE. ***') GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE DNTRAN(N,ANU,DELTA,LAMBDA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE STUDENT'S DOUBLY NON-CENTRAL T DISTRIBUTION C WITH INTEGER DEGREES OF FREEDOM PARAMETER NU AND C NON-CENTRALITY PARAMETERS DELTA AND LAMBDA. 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. C --DELTA = THE REAL NON-CENTRALITY PARAMETER C DELTA. C --LAMBDA = THE REAL NON-CENTRALITY PARAMETER C LAMBDA. 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 STUDENT'S DOUBLY NON-CENTRAL T DISTRIBUTION C WITH DEGREES OF FREEDOM PARAMETER = NU AND C NON-CENTRALITY PARAMETERS DELTA AND LAMBDA. 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 FORDNTRAN LIBRARY SUBROUTINES NEEDED--ALOG, SQRT, SIN, COS. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORDNTRAN (1977) C REFERENCES--MOOD AND GRABLE, INTRODUCTION TO THE C THEORY OF STATISTICS, 1963, PAGE 233. C --JOHNSON, KOTZ, AND BALAKRISHNAN, CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME 2, SECOND EDITION, C 1994, CHAPTER 31. 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-921-3651 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 EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2004.3 C ORIGINAL VERSION--MARCH 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL LAMBDA REAL DELTA 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 ') GOTO9000 ENDIF IF(ANU.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48)ANU CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF DOUBLY NONCENTRAL', 1' T RANDOM NUMBERS IS NON-POSITIVE') 15 FORMAT('***** ERROR--THE DEGREES OF FREEDOM PARAMETER FOR THE ', 1'DOUBLY NON-CENTRAL T RANDOM NUMBERS IS NON-POSITIVE') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',F12.5) C C GENERATE N STUDENT'S DOUBLY NON-CENTRAL T RANDOM NUMBERS C USING THE DEFINITION THAT A STUDENT'S DOUBLY NON-CENTRAL T C VARIATE WITH NU DEGREES OF FREEDOM AND NON-CENTRALITY C PARAMETERS DELTA AND LAMBDA EQUALS A NORMAL VARIATE WITH C LOCATION PARAMETER DELTA DIVIDED BY C SQRT(NON-CENTRAL-CHI-SQUARED(NU,LAMBDA)/NU). C FIRST GENERATE A NORMAL RANDOM NUMBER WITH LOCATION PARAMETER C DELTA, THEN GENERATE THE NON-CENTRAL CHI-SQUARE NUMBER. C THEN FORM THE RATIO OF THE FIRST DIVIDED BY THE SECOND. C DO100I=1,N C C NORMAL RANDOM NUMBER WITH LOCATION PARAMETER DELTA C CALL UNIRAN(2,ISEED,Y) ARG1=-2.0*ALOG(Y(1)) ARG2=2.0*PI*Y(2) ZNORM=(SQRT(ARG1))*(COS(ARG2)) + DELTA C C NON-CENTRAL CHI-SQUARE RANDOM NUMBER C CALL NCCRAN(NTEMP,ANU,LAMBDA,ISEED,Y) X(I)=ZNORM/SQRT(Y(1)/ANU) C 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE DOGDRV(NR,N,X,F,G,A,P,XPLS,FPLS,SX,STEPMX, CDPLT SUBROUTINE DOGDRV(NR,N,X,F,G,A,P,XPLS,FPLS,OPTFCN,SX,STEPMX, + STEPTL,DLT,IRETCD,MXTAKE,SC,WRK1,WRK2,WRK3,IPR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C PURPOSE C ------- C FIND A NEXT NEWTON ITERATE (XPLS) BY THE DOUBLE DOGLEG METHOD C C PARAMETERS C ---------- C NR --> ROW DIMENSION OF MATRIX C N --> DIMENSION OF PROBLEM C X(N) --> OLD ITERATE X[K-1] C F --> FUNCTION VALUE AT OLD ITERATE, F(X) C G(N) --> GRADIENT AT OLD ITERATE, G(X), OR APPROXIMATE C A(N,N) --> CHOLESKY DECOMPOSITION OF HESSIAN C IN LOWER TRIANGULAR PART AND DIAGONAL C P(N) --> NEWTON STEP C XPLS(N) <-- NEW ITERATE X[K] C FPLS <-- FUNCTION VALUE AT NEW ITERATE, F(XPLS) C FCN --> NAME OF SUBROUTINE TO EVALUATE FUNCTION C SX(N) --> DIAGONAL SCALING MATRIX FOR X C STEPMX --> MAXIMUM ALLOWABLE STEP SIZE C STEPTL --> RELATIVE STEP SIZE AT WHICH SUCCESSIVE ITERATES C CONSIDERED CLOSE ENOUGH TO TERMINATE ALGORITHM C DLT <--> TRUST REGION RADIUS C [RETAIN VALUE BETWEEN SUCCESSIVE CALLS] C IRETCD <-- RETURN CODE C =0 SATISFACTORY XPLS FOUND C =1 FAILED TO FIND SATISFACTORY XPLS SUFFICIENTLY C DISTINCT FROM X C MXTAKE <-- BOOLEAN FLAG INDICATING STEP OF MAXIMUM LENGTH USED C SC(N) --> WORKSPACE [CURRENT STEP] C WRK1(N) --> WORKSPACE (AND PLACE HOLDING ARGUMENT TO TREGUP) C WRK2(N) --> WORKSPACE C WRK3(N) --> WORKSPACE C IPR --> DEVICE TO WHICH TO SEND OUTPUT C DIMENSION X(N),XPLS(N),G(N),P(N) DIMENSION SX(N) DIMENSION SC(N),WRK1(N),WRK2(N),WRK3(N) DIMENSION A(NR,1) LOGICAL FSTDOG,NWTAKE,MXTAKE CDPLT EXTERNAL OPTFCN C IRETCD=4 FSTDOG=.TRUE. TMP=0. DO 5 I=1,N TMP=TMP+SX(I)*SX(I)*P(I)*P(I) 5 CONTINUE RNWTLN=SQRT(TMP) C$ WRITE(IPR,954) RNWTLN C 100 CONTINUE C C FIND NEW STEP BY DOUBLE DOGLEG ALGORITHM CALL DOGSTP(NR,N,G,A,P,SX,RNWTLN,DLT,NWTAKE,FSTDOG, + WRK1,WRK2,CLN,ETA,SC,IPR,STEPMX) C C CHECK NEW POINT AND UPDATE TRUST REGION CDPLT CALL TREGUP(NR,N,X,F,G,A,OPTFCN,SC,SX,NWTAKE,STEPMX,STEPTL,DLT, CALL TREGUP(NR,N,X,F,G,A,SC,SX,NWTAKE,STEPMX,STEPTL,DLT, + IRETCD,WRK3,FPLSP,XPLS,FPLS,MXTAKE,IPR,2,WRK1) IF(IRETCD.LE.1) RETURN GO TO 100 CC950 FORMAT(42H DOGDRV INITIAL TRUST REGION NOT GIVEN., CC + 22H COMPUTE CAUCHY STEP.) CC951 FORMAT(18H DOGDRV ALPHA =,E20.13/ CC + 18H DOGDRV BETA =,E20.13/ CC + 18H DOGDRV DLT =,E20.13/ CC + 18H DOGDRV NWTAKE=,L1 ) CC952 FORMAT(28H DOGDRV CURRENT STEP (SC)) CC954 FORMAT(18H0DOGDRV RNWTLN=,E20.13) CC955 FORMAT(14H DOGDRV ,5(E20.13,3X)) END SUBROUTINE DOGSTP(NR,N,G,A,P,SX,RNWTLN,DLT,NWTAKE,FSTDOG, + SSD,V,CLN,ETA,SC,IPR,STEPMX) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C PURPOSE C ------- C FIND NEW STEP BY DOUBLE DOGLEG ALGORITHM C C PARAMETERS C ---------- C NR --> ROW DIMENSION OF MATRIX C N --> DIMENSION OF PROBLEM C G(N) --> GRADIENT AT CURRENT ITERATE, G(X) C A(N,N) --> CHOLESKY DECOMPOSITION OF HESSIAN IN C LOWER PART AND DIAGONAL C P(N) --> NEWTON STEP C SX(N) --> DIAGONAL SCALING MATRIX FOR X C RNWTLN --> NEWTON STEP LENGTH C DLT <--> TRUST REGION RADIUS C NWTAKE <--> BOOLEAN, =.TRUE. IF NEWTON STEP TAKEN C FSTDOG <--> BOOLEAN, =.TRUE. IF ON FIRST LEG OF DOGLEG C SSD(N) <--> WORKSPACE [CAUCHY STEP TO THE MINIMUM OF THE C QUADRATIC MODEL IN THE SCALED STEEPEST DESCENT C DIRECTION] [RETAIN VALUE BETWEEN SUCCESSIVE CALLS] C V(N) <--> WORKSPACE [RETAIN VALUE BETWEEN SUCCESSIVE CALLS] C CLN <--> CAUCHY LENGTH C [RETAIN VALUE BETWEEN SUCCESSIVE CALLS] C ETA [RETAIN VALUE BETWEEN SUCCESSIVE CALLS] C SC(N) <-- CURRENT STEP C IPR --> DEVICE TO WHICH TO SEND OUTPUT C STEPMX --> MAXIMUM ALLOWABLE STEP SIZE C C INTERNAL VARIABLES C ------------------ C CLN LENGTH OF CAUCHY STEP C DIMENSION G(N),P(N) DIMENSION SX(N) DIMENSION SC(N),SSD(N),V(N) DIMENSION A(NR,1) LOGICAL NWTAKE,FSTDOG IPR=IPR C C CAN WE TAKE NEWTON STEP C IF(RNWTLN.GT.DLT) GO TO 100 C IF(RNWTLN.LE.DLT) C THEN NWTAKE=.TRUE. DO 10 I=1,N SC(I)=P(I) 10 CONTINUE DLT=RNWTLN C$ WRITE(IPR,951) GO TO 700 C ELSE C C NEWTON STEP TOO LONG C CAUCHY STEP IS ON DOUBLE DOGLEG CURVE C 100 NWTAKE=.FALSE. IF(.NOT.FSTDOG) GO TO 200 C IF(FSTDOG) C THEN C C CALCULATE DOUBLE DOGLEG CURVE (SSD) FSTDOG=.FALSE. ALPHA=0. DO 110 I=1,N ALPHA=ALPHA + (G(I)*G(I))/(SX(I)*SX(I)) 110 CONTINUE BETA=0. DO 130 I=1,N TMP=0. DO 120 J=I,N TMP=TMP + (A(J,I)*G(J))/(SX(J)*SX(J)) 120 CONTINUE BETA=BETA+TMP*TMP 130 CONTINUE DO 140 I=1,N SSD(I)=-(ALPHA/BETA)*G(I)/SX(I) 140 CONTINUE CLN=ALPHA*SQRT(ALPHA)/BETA ETA=.2 + (.8*ALPHA*ALPHA)/(-BETA*DDOT(N,G,1,P,1)) DO 150 I=1,N V(I)=ETA*SX(I)*P(I) - SSD(I) 150 CONTINUE IF (DLT .EQ. (-1.0)) DLT = MIN(CLN, STEPMX) C$ WRITE(IPR,954) ALPHA,BETA,CLN,ETA C$ WRITE(IPR,955) C$ WRITE(IPR,960) (SSD(I),I=1,N) C$ WRITE(IPR,956) C$ WRITE(IPR,960) (V(I),I=1,N) C ENDIF 200 IF(ETA*RNWTLN.GT.DLT) GO TO 220 C IF(ETA*RNWTLN .LE. DLT) C THEN C C TAKE PARTIAL STEP IN NEWTON DIRECTION C DO 210 I=1,N SC(I)=(DLT/RNWTLN)*P(I) 210 CONTINUE C$ WRITE(IPR,957) GO TO 700 C ELSE 220 IF(CLN.LT.DLT) GO TO 240 C IF(CLN.GE.DLT) C THEN C TAKE STEP IN STEEPEST DESCENT DIRECTION C DO 230 I=1,N SC(I)=(DLT/CLN)*SSD(I)/SX(I) 230 CONTINUE C$ WRITE(IPR,958) GO TO 700 C ELSE C C CALCULATE CONVEX COMBINATION OF SSD AND ETA*P C WHICH HAS SCALED LENGTH DLT C 240 DOT1=DDOT(N,V,1,SSD,1) DOT2=DDOT(N,V,1,V,1) ALAM=(-DOT1+SQRT((DOT1*DOT1)-DOT2*(CLN*CLN-DLT*DLT)))/DOT2 DO 250 I=1,N SC(I)=(SSD(I) + ALAM*V(I))/SX(I) 250 CONTINUE C$ WRITE(IPR,959) C ENDIF C ENDIF C ENDIF 700 CONTINUE C$ WRITE(IPR,952) FSTDOG,NWTAKE,RNWTLN,DLT C$ WRITE(IPR,953) C$ WRITE(IPR,960) (SC(I),I=1,N) RETURN C 951 FORMAT(27H0DOGSTP TAKE NEWTON STEP) 952 FORMAT(18H DOGSTP FSTDOG=,L1/ + 18H DOGSTP NWTAKE=,L1/ + 18H DOGSTP RNWTLN=,E20.13/ + 18H DOGSTP DLT =,E20.13) 953 FORMAT(28H DOGSTP CURRENT STEP (SC)) 954 FORMAT(18H DOGSTP ALPHA =,E20.13/ + 18H DOGSTP BETA =,E20.13/ + 18H DOGSTP CLN =,E20.13/ + 18H DOGSTP ETA =,E20.13) 955 FORMAT(28H DOGSTP CAUCHY STEP (SSD)) 956 FORMAT(12H DOGSTP V) 957 FORMAT(48H0DOGSTP TAKE PARTIAL STEP IN NEWTON DIRECTION) 958 FORMAT(50H0DOGSTP TAKE STEP IN STEEPEST DESCENT DIRECTION) 959 FORMAT(39H0DOGSTP TAKE CONVEX COMBINATION STEP) 960 FORMAT(14H DOGSTP ,5(E20.13,3X)) END SUBROUTINE DOTPRO(V1,V2,N,DP) C C PURPOSE--TO COMPUTE THE DOT PRODUCT C BETWEEN 2 SINGLE-PRECISION VECTORS-- C V1 AND V2. C THE OUTPUT WILL BWE THE SINGLE PRECISION VALUE DP. C ALL INTERNAL CALCULATIONS ARE CARRIED C OUT IN DOUBLE PRECISION.T 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-921-3651 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--DECEMBER 1978. C UPDATED --FEBRUARY 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DSUM,DV1,DV2,DPROD DIMENSION V1(*) DIMENSION V2(*) 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 DSUM=0.0D0 DO100I=1,N DV1=V1(I) DV2=V2(I) DPROD=DV1*DV2 DSUM=DSUM+DPROD 100 CONTINUE DP=DSUM C RETURN END SUBROUTINE DP1H4H(ISTART,ISTOP,ISTRIN, 1IWORD1,IWORD2,IWORD3,NUMWD,NUMCH,IBUG1H,IERROR) C C PURPOSE--CONVERT THE STRING FOUND IN LOCATIONS ISTART C THROUGH ISTOP (INCLUSIVE) IN ISTRIN(.). C FROM 1 CHARACTER PER WORD REPRESENTATIONS C TO PACKED 4 CHARACTERS PER WORD REPRESENTATIONS C IN IWORD1, IWORD2, AND IWORD3. C NOTE--AT MOST 12 CHARACTERS WILL BE OPERATED ON. C NOTE--AT MOST 3 WORDS WILL BE FORMED. 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-921-3651 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--MARCH 1979. C UPDATED --JANUARY 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ISTRIN CHARACTER*4 IWORD1 CHARACTER*4 IWORD2 CHARACTER*4 IWORD3 CHARACTER*4 IBUG1H CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION ISTRIN(*) C C NUMBPC = NUMBER OF BITS PER CHARACTER. C NUMCPW = NUMBER OF CHARACTERS PER WORD. C THESE VALUES WILL CHANGE DEPENDING C ON THE COMPUTER AND ARE DEFINED IN THE SUBROUTINE INITMC. C HOWEVER, IN ANY EVENT, THE OUTPUT FROM THIS C SUBROUTINE WILL BE 4 CHARACTERS PER WORD C (FOR A MORE GENERAL SUBROUTINE, SEE DP1HXH). 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='DP1H' ISUBN2='4H ' C IERROR='NO' C NUMASC=4 C IF(IBUG1H.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DP1H4H--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ISTART,ISTOP 52 FORMAT('ISTART,ISTOP = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)(ISTRIN(I),I=ISTART,ISTOP) 53 FORMAT('ISTRIN(.) = ',115A1) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************** C ** STEP 1-- ** C ** INITIALIZE SOME VARIABLES. ** C ********************************** C ISTEPN='1' IF(IBUG1H.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IEND=0 IWORD1=' ' IWORD2=' ' IWORD3=' ' NUMWD=0 NUMCH=0 C C ************************************* C ** STEP 2-- ** C ** PACK 4 CHARACTERS INTO A WORD ** C ** FOR AS MANY AS 3 WORDS. ** C ************************************* C ISTEPN='2' IF(IBUG1H.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C I1MIN=1 I1MAX=NUMASC I2MIN=I1MAX+1 I2MAX=2*I1MAX I3MIN=I2MAX+1 I3MAX=3*I1MAX C J=0 IF(ISTART.GT.ISTOP)GOTO250 ISTOP2=ISTART+3*NUMASC-1 IMAX=ISTOP IF(ISTOP.GT.ISTOP2)IMAX=ISTOP2 DO200I=ISTART,IMAX J=J+1 JM1=J-1 L=J-(NUMASC*(JM1/NUMASC)) K=NUMBPC*(L-1) K=IABS(K) IF(I1MIN.LE.J.AND.J.LE.I1MAX)GOTO211 IF(I2MIN.LE.J.AND.J.LE.I2MAX)GOTO212 IF(I3MIN.LE.J.AND.J.LE.I3MAX)GOTO213 GOTO250 211 CONTINUE CALL DPCHEX(0,NUMBPC,ISTRIN(I),K,NUMBPC,IWORD1) NUMWD=1 GOTO200 212 CONTINUE CALL DPCHEX(0,NUMBPC,ISTRIN(I),K,NUMBPC,IWORD2) NUMWD=2 GOTO200 213 CONTINUE CALL DPCHEX(0,NUMBPC,ISTRIN(I),K,NUMBPC,IWORD3) NUMWD=3 200 CONTINUE 250 CONTINUE NUMCH=J C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C C 9000 CONTINUE C IF(IBUG1H.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DP1H4H--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NUMBPC,NUMCPW,NUMASC 9012 FORMAT('NUMBPC,NUMCPW,NUMASC = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NUMWD,NUMCH 9013 FORMAT('NUMWD, NUMCH = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IWORD1,IWORD2,IWORD3 9014 FORMAT('IWORD1,IWORD2,IWORD3 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END DOUBLE PRECISION FUNCTION DPOCH (A, X) C***BEGIN PROLOGUE DPOCH C***PURPOSE Evaluate a generalization of Pochhammer's symbol. C***LIBRARY SLATEC (FNLIB) C***CATEGORY C1, C7A C***TYPE DOUBLE PRECISION (POCH-S, DPOCH-D) C***KEYWORDS FNLIB, POCHHAMMER, SPECIAL FUNCTIONS C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C Evaluate a double precision generalization of Pochhammer's symbol C (A)-sub-X = GAMMA(A+X)/GAMMA(A) for double precision A and X. C For X a non-negative integer, POCH(A,X) is just Pochhammer's symbol. C This is a preliminary version that does not handle wrong arguments C properly and may not properly handle the case when the result is C computed to less than half of double precision. C C***REFERENCES (NONE) C***ROUTINES CALLED D9LGMC, DFAC, DGAMMA, DGAMR, DLGAMS, DLNREL, XERMSG C***REVISION HISTORY (YYMMDD) C 770701 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890911 Removed unnecessary intrinsics. (WRB) C 890911 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 900727 Added EXTERNAL statement. (WRB) C***END PROLOGUE DPOCH 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 A, X, ABSA, ABSAX, ALNGA, ALNGAX, AX, B, PI, 1 SGNGA, SGNGAX, DFAC, DLNREL, D9LGMC, DGAMMA, DGAMR, DCOT EXTERNAL DGAMMA EXTERNAL DCOT SAVE PI DATA PI / 3.1415926535 8979323846 2643383279 503 D0 / C***FIRST EXECUTABLE STATEMENT DPOCH AX = A + X IF (AX.GT.0.0D0) GO TO 30 IF (AINT(AX).NE.AX) GO TO 30 C IF (A .GT. 0.0D0 .OR. AINT(A) .NE. A) THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') RETURN ENDIF 1 FORMAT('***** ERROR FROM DPOCH, A+X IS A NON-POSITIVE INTERGER ', 1 'BUT A IS NOT. *****') C C WE KNOW HERE THAT BOTH A+X AND A ARE NON-POSITIVE INTEGERS. C DPOCH = 1.0D0 IF (X.EQ.0.D0) RETURN C N = X IF (MIN(A+X,A).LT.(-20.0D0)) GO TO 20 C IA = A DPOCH = (-1.0D0)**N * DFAC(-IA)/DFAC(-IA-N) RETURN C 20 DPOCH = (-1.0D0)**N * EXP ((A-0.5D0)*DLNREL(X/(A-1.0D0)) 1 + X*LOG(-A+1.0D0-X) - X + D9LGMC(-A+1.0D0) - D9LGMC(-A-X+1.D0)) RETURN C C A+X IS NOT ZERO OR A NEGATIVE INTEGER. C 30 DPOCH = 0.0D0 IF (A.LE.0.0D0 .AND. AINT(A).EQ.A) RETURN C N = ABS(X) IF (DBLE(N).NE.X .OR. N.GT.20) GO TO 50 C C X IS A SMALL NON-POSITIVE INTEGER, PRESUMMABLY A COMMON CASE. C DPOCH = 1.0D0 IF (N.EQ.0) RETURN DO 40 I=1,N DPOCH = DPOCH * (A+I-1) 40 CONTINUE RETURN C 50 ABSAX = ABS(A+X) ABSA = ABS(A) IF (MAX(ABSAX,ABSA).GT.20.0D0) GO TO 60 DPOCH = DGAMMA(A+X) * DGAMR(A) RETURN C 60 IF (ABS(X).GT.0.5D0*ABSA) GO TO 70 C C ABS(X) IS SMALL AND BOTH ABS(A+X) AND ABS(A) ARE LARGE. THUS, C A+X AND A MUST HAVE THE SAME SIGN. FOR NEGATIVE A, WE USE C GAMMA(A+X)/GAMMA(A) = GAMMA(-A+1)/GAMMA(-A-X+1) * C SIN(PI*A)/SIN(PI*(A+X)) C B = A IF (B.LT.0.0D0) B = -A - X + 1.0D0 DPOCH = EXP ((B-0.5D0)*DLNREL(X/B) + X*LOG(B+X) - X 1 + D9LGMC(B+X) - D9LGMC(B) ) IF (A.LT.0.0D0 .AND. DPOCH.NE.0.0D0) DPOCH = 1 DPOCH/(COS(PI*X) + DCOT(PI*A)*SIN(PI*X) ) RETURN C 70 CALL DLGAMS (A+X, ALNGAX, SGNGAX) CALL DLGAMS (A, ALNGA, SGNGA) DPOCH = SGNGAX * SGNGA * EXP(ALNGAX-ALNGA) C RETURN END DOUBLE PRECISION FUNCTION DPOCH1(A, X) C***BEGIN PROLOGUE DPOCH1 C***PURPOSE Calculate a generalization of Pochhammer's symbol starting C from first order. C***LIBRARY SLATEC (FNLIB) C***CATEGORY C1, C7A C***TYPE DOUBLE PRECISION (POCH1-S, DPOCH1-D) C***KEYWORDS FIRST ORDER, FNLIB, POCHHAMMER, SPECIAL FUNCTIONS C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C Evaluate a double precision generalization of Pochhammer's symbol C for double precision A and X for special situations that require C especially accurate values when X is small in C POCH1(A,X) = (POCH(A,X)-1)/X C = (GAMMA(A+X)/GAMMA(A) - 1.0)/X . C This specification is particularly suited for stably computing C expressions such as C (GAMMA(A+X)/GAMMA(A) - GAMMA(B+X)/GAMMA(B))/X C = POCH1(A,X) - POCH1(B,X) C Note that POCH1(A,0.0) = PSI(A) C C When ABS(X) is so small that substantial cancellation will occur if C the straightforward formula is used, we use an expansion due C to Fields and discussed by Y. L. Luke, The Special Functions and Their C Approximations, Vol. 1, Academic Press, 1969, page 34. C C The ratio POCH(A,X) = GAMMA(A+X)/GAMMA(A) is written by Luke as C (A+(X-1)/2)**X * polynomial in (A+(X-1)/2)**(-2) . C In order to maintain significance in POCH1, we write for positive a C (A+(X-1)/2)**X = EXP(X*LOG(A+(X-1)/2)) = EXP(Q) C = 1.0 + Q*EXPREL(Q) . C Likewise the polynomial is written C POLY = 1.0 + X*POLY1(A,X) . C Thus, C POCH1(A,X) = (POCH(A,X) - 1) / X C = EXPREL(Q)*(Q/X + Q*POLY1(A,X)) + POLY1(A,X) C C***REFERENCES (NONE) C***ROUTINES CALLED D1MACH, DCOT, DEXPRL, DPOCH, DPSI, XERMSG C***REVISION HISTORY (YYMMDD) C 770801 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890911 Removed unnecessary intrinsics. (WRB) C 890911 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 900727 Added EXTERNAL statement. (WRB) C***END PROLOGUE DPOCH1 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 A, X, ABSA, ABSX, ALNEPS, ALNVAR, B, BERN(20), 1 BINV, BP, GBERN(21), GBK, PI, POLY1, Q, RHO, SINPXX, SINPX2, 2 SQTBIG, TERM, TRIG, VAR, VAR2, DPSI, DEXPRL, DCOT, DPOCH LOGICAL FIRST EXTERNAL DCOT SAVE BERN, PI, SQTBIG, ALNEPS, FIRST DATA BERN ( 1) / +.8333333333 3333333333 3333333333 333 D-1 / DATA BERN ( 2) / -.1388888888 8888888888 8888888888 888 D-2 / DATA BERN ( 3) / +.3306878306 8783068783 0687830687 830 D-4 / DATA BERN ( 4) / -.8267195767 1957671957 6719576719 576 D-6 / DATA BERN ( 5) / +.2087675698 7868098979 2100903212 014 D-7 / DATA BERN ( 6) / -.5284190138 6874931848 4768220217 955 D-9 / DATA BERN ( 7) / +.1338253653 0684678832 8269809751 291 D-10 / DATA BERN ( 8) / -.3389680296 3225828668 3019539124 944 D-12 / DATA BERN ( 9) / +.8586062056 2778445641 3590545042 562 D-14 / DATA BERN ( 10) / -.2174868698 5580618730 4151642386 591 D-15 / DATA BERN ( 11) / +.5509002828 3602295152 0265260890 225 D-17 / DATA BERN ( 12) / -.1395446468 5812523340 7076862640 635 D-18 / DATA BERN ( 13) / +.3534707039 6294674716 9322997780 379 D-20 / DATA BERN ( 14) / -.8953517427 0375468504 0261131811 274 D-22 / DATA BERN ( 15) / +.2267952452 3376830603 1095073886 816 D-23 / DATA BERN ( 16) / -.5744724395 2026452383 4847971943 400 D-24 / DATA BERN ( 17) / +.1455172475 6148649018 6626486727 132 D-26 / DATA BERN ( 18) / -.3685994940 6653101781 8178247990 866 D-28 / DATA BERN ( 19) / +.9336734257 0950446720 3255515278 562 D-30 / DATA BERN ( 20) / -.2365022415 7006299345 5963519636 983 D-31 / DATA PI / 3.1415926535 8979323846 2643383279 503 D0 / DATA FIRST /.TRUE./ C***FIRST EXECUTABLE STATEMENT DPOCH1 IF (FIRST) THEN SQTBIG = 1.0D0/SQRT(24.0D0*D1MACH(1)) ALNEPS = LOG(D1MACH(3)) ENDIF FIRST = .FALSE. C IF (X.EQ.0.0D0) DPOCH1 = DPSI(A) IF (X.EQ.0.0D0) RETURN C ABSX = ABS(X) ABSA = ABS(A) IF (ABSX.GT.0.1D0*ABSA) GO TO 70 IF (ABSX*LOG(MAX(ABSA,2.0D0)).GT.0.1D0) GO TO 70 C BP = A IF (A.LT.(-0.5D0)) BP = 1.0D0 - A - X INCR = 0 IF (BP.LT.10.0D0) INCR = 11.0D0 - BP B = BP + INCR C VAR = B + 0.5D0*(X-1.0D0) ALNVAR = LOG(VAR) Q = X*ALNVAR C POLY1 = 0.0D0 IF (VAR.GE.SQTBIG) GO TO 40 VAR2 = (1.0D0/VAR)**2 C RHO = 0.5D0*(X+1.0D0) GBERN(1) = 1.0D0 GBERN(2) = -RHO/12.0D0 TERM = VAR2 POLY1 = GBERN(2)*TERM C NTERMS = -0.5D0*ALNEPS/ALNVAR + 1.0D0 CCCCC+ 'NTERMS IS TOO BIG, MAYBE D1MACH(3) IS BAD', 1, 2) IF (NTERMS .GT. 20) THEN WRITE(ICOUT,1) 1 FORMAT('***** ERORR FROM DPOCH1, INTERNAL ERROR. *******') CALL DPWRST('XXX','BUG ') RETURN ENDIF IF (NTERMS.LT.2) GO TO 40 C DO 30 K=2,NTERMS GBK = 0.0D0 DO 20 J=1,K NDX = K - J + 1 GBK = GBK + BERN(NDX)*GBERN(J) 20 CONTINUE GBERN(K+1) = -RHO*GBK/K C TERM = TERM * (2*K-2-X)*(2*K-1-X)*VAR2 POLY1 = POLY1 + GBERN(K+1)*TERM 30 CONTINUE C 40 POLY1 = (X-1.0D0)*POLY1 DPOCH1 = DEXPRL(Q)*(ALNVAR+Q*POLY1) + POLY1 C IF (INCR.EQ.0) GO TO 60 C C WE HAVE DPOCH1(B,X), BUT BP IS SMALL, SO WE USE BACKWARDS RECURSION C TO OBTAIN DPOCH1(BP,X). C DO 50 II=1,INCR I = INCR - II BINV = 1.0D0/(BP+I) DPOCH1 = (DPOCH1 - BINV) / (1.0D0 + X*BINV) 50 CONTINUE C 60 IF (BP.EQ.A) RETURN C C WE HAVE DPOCH1(BP,X), BUT A IS LT -0.5. WE THEREFORE USE A REFLECTION C FORMULA TO OBTAIN DPOCH1(A,X). C SINPXX = SIN(PI*X)/X SINPX2 = SIN(0.5D0*PI*X) TRIG = SINPXX*DCOT(PI*B) - 2.0D0*SINPX2*(SINPX2/X) C DPOCH1 = TRIG + (1.0D0 + X*TRIG)*DPOCH1 RETURN C 70 DPOCH1 = (DPOCH(A,X) - 1.0D0) / X RETURN C END DOUBLE PRECISION FUNCTION DPSI (X) C***BEGIN PROLOGUE DPSI C***PURPOSE Compute the Psi (or Digamma) function. C***LIBRARY SLATEC (FNLIB) C***CATEGORY C7C C***TYPE DOUBLE PRECISION (PSI-S, DPSI-D, CPSI-C) C***KEYWORDS DIGAMMA FUNCTION, FNLIB, PSI FUNCTION, SPECIAL FUNCTIONS C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C DPSI calculates the double precision Psi (or Digamma) function for C double precision argument X. PSI(X) is the logarithmic derivative C of the Gamma function of X. C C Series for PSI on the interval 0. to 1.00000E+00 C with weighted error 5.79E-32 C log weighted error 31.24 C significant figures required 30.93 C decimal places required 32.05 C C C Series for APSI on the interval 0. to 1.00000E-02 C with weighted error 7.75E-33 C log weighted error 32.11 C significant figures required 28.88 C decimal places required 32.71 C C***REFERENCES (NONE) C***ROUTINES CALLED D1MACH, DCOT, DCSEVL, INITDS, XERMSG C***REVISION HISTORY (YYMMDD) C 770601 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890911 Removed unnecessary intrinsics. (WRB) C 890911 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 900727 Added EXTERNAL statement. (WRB) C 920618 Removed space from variable name. (RWC, WRB) C***END PROLOGUE DPSI 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, PSICS(42), APSICS(16), AUX, DXREL, PI, XBIG, 1 Y, DCOT, DCSEVL LOGICAL FIRST EXTERNAL DCOT SAVE PSICS, APSICS, PI, NTPSI, NTAPSI, XBIG, DXREL, FIRST DATA PSICS( 1) / -.3805708083 5217921520 4376776670 39 D-1 / DATA PSICS( 2) / +.4914153930 2938712748 2046996542 77 D+0 / DATA PSICS( 3) / -.5681574782 1244730242 8920647340 81 D-1 / DATA PSICS( 4) / +.8357821225 9143131362 7756507478 62 D-2 / DATA PSICS( 5) / -.1333232857 9943425998 0792741723 93 D-2 / DATA PSICS( 6) / +.2203132870 6930824892 8723979795 21 D-3 / DATA PSICS( 7) / -.3704023817 8456883592 8890869492 29 D-4 / DATA PSICS( 8) / +.6283793654 8549898933 6514187176 90 D-5 / DATA PSICS( 9) / -.1071263908 5061849855 2835417470 74 D-5 / DATA PSICS( 10) / +.1831283946 5484165805 7315898103 78 D-6 / DATA PSICS( 11) / -.3135350936 1808509869 0057797968 85 D-7 / DATA PSICS( 12) / +.5372808776 2007766260 4719191436 15 D-8 / DATA PSICS( 13) / -.9211681415 9784275717 8806326247 30 D-9 / DATA PSICS( 14) / +.1579812652 1481822782 2528840328 23 D-9 / DATA PSICS( 15) / -.2709864613 2380443065 4405894097 07 D-10 / DATA PSICS( 16) / +.4648722859 9096834872 9473195295 49 D-11 / DATA PSICS( 17) / -.7975272563 8303689726 5047977727 37 D-12 / DATA PSICS( 18) / +.1368272385 7476992249 2510538928 38 D-12 / DATA PSICS( 19) / -.2347515606 0658972717 3206779807 19 D-13 / DATA PSICS( 20) / +.4027630715 5603541107 9079250062 81 D-14 / DATA PSICS( 21) / -.6910251853 1179037846 5474229747 71 D-15 / DATA PSICS( 22) / +.1185604713 8863349552 9291395257 68 D-15 / DATA PSICS( 23) / -.2034168961 6261559308 1542104842 23 D-16 / DATA PSICS( 24) / +.3490074968 6463043850 3742329323 51 D-17 / DATA PSICS( 25) / -.5988014693 4976711003 0110813934 93 D-18 / DATA PSICS( 26) / +.1027380162 8080588258 3980057122 13 D-18 / DATA PSICS( 27) / -.1762704942 4561071368 3592601053 86 D-19 / DATA PSICS( 28) / +.3024322801 8156920457 4540354901 33 D-20 / DATA PSICS( 29) / -.5188916830 2092313774 2860888746 66 D-21 / DATA PSICS( 30) / +.8902773034 5845713905 0058874879 99 D-22 / DATA PSICS( 31) / -.1527474289 9426728392 8949719040 00 D-22 / DATA PSICS( 32) / +.2620731479 8962083136 3583180799 99 D-23 / DATA PSICS( 33) / -.4496464273 8220696772 5983880533 33 D-24 / DATA PSICS( 34) / +.7714712959 6345107028 9193642666 66 D-25 / DATA PSICS( 35) / -.1323635476 1887702968 1026389333 33 D-25 / DATA PSICS( 36) / +.2270999436 2408300091 2773119999 99 D-26 / DATA PSICS( 37) / -.3896419021 5374115954 4913919999 99 D-27 / DATA PSICS( 38) / +.6685198138 8855302310 6798933333 33 D-28 / DATA PSICS( 39) / -.1146998665 4920864872 5299199999 99 D-28 / DATA PSICS( 40) / +.1967938588 6541405920 5154133333 33 D-29 / DATA PSICS( 41) / -.3376448818 9750979801 9072000000 00 D-30 / DATA PSICS( 42) / +.5793070319 3214159246 6773333333 33 D-31 / DATA APSICS( 1) / -.8327107910 6929076017 4456932269 D-3 / DATA APSICS( 2) / -.4162518421 9273935282 1627121990 D-3 / DATA APSICS( 3) / +.1034315609 7874129117 4463193961 D-6 / DATA APSICS( 4) / -.1214681841 3590415298 7299556365 D-9 / DATA APSICS( 5) / +.3113694319 9835615552 1240278178 D-12 / DATA APSICS( 6) / -.1364613371 9317704177 6516100945 D-14 / DATA APSICS( 7) / +.9020517513 1541656513 0837974000 D-17 / DATA APSICS( 8) / -.8315429974 2159146482 9933635466 D-19 / DATA APSICS( 9) / +.1012242570 7390725418 8479482666 D-20 / DATA APSICS( 10) / -.1562702494 3562250762 0478933333 D-22 / DATA APSICS( 11) / +.2965427168 0890389613 3226666666 D-24 / DATA APSICS( 12) / -.6746868867 6570216374 1866666666 D-26 / DATA APSICS( 13) / +.1803453116 9718990421 3333333333 D-27 / DATA APSICS( 14) / -.5569016182 4598360746 6666666666 D-29 / DATA APSICS( 15) / +.1958679226 0773625173 3333333333 D-30 / DATA APSICS( 16) / -.7751958925 2333568000 0000000000 D-32 / DATA PI / 3.1415926535 8979323846 2643383279 50 D0 / DATA FIRST /.TRUE./ C***FIRST EXECUTABLE STATEMENT DPSI IF (FIRST) THEN NTPSI = INITDS (PSICS, 42, 0.1*REAL(D1MACH(3)) ) NTAPSI = INITDS (APSICS, 16, 0.1*REAL(D1MACH(3)) ) C XBIG = 1.0D0/SQRT(D1MACH(3)) DXREL = SQRT(D1MACH(4)) ENDIF FIRST = .FALSE. C Y = ABS(X) C IF (Y.GT.10.0D0) GO TO 50 C C DPSI(X) FOR ABS(X) .LE. 2 C N = X IF (X.LT.0.D0) N = N - 1 Y = X - N N = N - 1 DPSI = DCSEVL (2.D0*Y-1.D0, PSICS, NTPSI) IF (N.EQ.0) RETURN C IF (N.GT.0) GO TO 30 C N = -N IF (X .EQ. 0.D0) THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') RETURN ENDIF 1 FORMAT('***** ERORR FROM DPSI, X IS ZERO.. *******') IF (X .LT. 0.D0 .AND. X+N-2 .EQ. 0.D0)THEN WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') RETURN ENDIF 2 FORMAT('***** ERORR FROM DPSI, X IS A NEGATIVE INTEGER. ******') IF (X.LT.(-0.5D0).AND.ABS((X-AINT(X-0.5D0))/X).LT.DXREL)THEN WRITE(ICOUT,3) CALL DPWRST('XXX','BUG ') ENDIF 3 FORMAT('***** WARNING FROM DPSI, ANSWER IS LESS THAN HALF ', 1 'PRECISION BECAUSE X IS TOO NEAR A NEGATIVE INTEGER. ****') C DO 20 I=1,N DPSI = DPSI - 1.D0/(X+I-1) 20 CONTINUE RETURN C C DPSI(X) FOR X .GE. 2.0 AND X .LE. 10.0 C 30 DO 40 I=1,N DPSI = DPSI + 1.0D0/(Y+I) 40 CONTINUE RETURN C C DPSI(X) FOR ABS(X) .GT. 10.0 C 50 AUX = 0.D0 IF (Y.LT.XBIG) AUX = DCSEVL (2.D0*(10.D0/Y)**2-1.D0, APSICS, 1 NTAPSI) C IF (X.LT.0.D0) DPSI = LOG(ABS(X)) - 0.5D0/X + AUX 1 - PI*DCOT(PI*X) IF (X.GT.0.D0) DPSI = LOG(X) - 0.5D0/X + AUX RETURN C END SUBROUTINE DP3DFR(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IANGLU,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE A 3-DIMENSIONAL FREQUENCY 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-921-3651 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--SEPTEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IANGLU CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 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='DP3D' ISUBN2='FR ' C IFOUND='NO' IERROR='NO' C IFOUND='YES' IERROR='YES' WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101) 101 FORMAT('***** ERROR IN DP3DFR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) 102 FORMAT(' 3-D FREQUENCY PLOT CAPABILITY') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103) 103 FORMAT(' NOT YET AVAILABLE') CALL DPWRST('XXX','BUG ') C RETURN END SUBROUTINE DP3DHI(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IANGLU,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE A 3-DIMENSIONAL HISTOGRAM. 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-921-3651 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--SEPTEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IANGLU CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 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='DP3D' ISUBN2='HI ' C IFOUND='NO' IERROR='NO' C IFOUND='YES' IERROR='YES' WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101) 101 FORMAT('***** ERROR IN DP3DHI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) 102 FORMAT(' 3-D HISTOGRAM CAPABILITY') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103) 103 FORMAT(' NOT YET AVAILABLE') CALL DPWRST('XXX','BUG ') C RETURN END SUBROUTINE DP3DP1(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1MAXNPP, 1IBUGG3,IBUGQ,IFOUND,IERROR) C C DONE? C PURPOSE--FORM A PARTICULAR 3-DIMENSIONAL PLOT-- C NAMELY, A Y VERSUS X1 AND X2 PLOT, C WHEN HAVE NO VERSUS AND NO EQUALS. 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-921-3651 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 1981. C UPDATED --OCTOBER 1981. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IHVERT CHARACTER*4 IHVER2 CHARACTER*4 IHHOR CHARACTER*4 IHHOR2 CHARACTER*4 IHHO2 CHARACTER*4 IHHO22 CHARACTER*4 IHSET CHARACTER*4 IHSET2 CHARACTER*4 IERRO4 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.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='DP3D' ISUBN2='P1 ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C NUMAR1=0 C D2MIN=0.0 DEL=0.0 C C ******************************** C ** STEP 10-- ** C ** TREAT THE CASE WHEN HAVE ** C ** NO VERSUS AND ** C ** NO FOR X = ** C ******************************** C 1000 CONTINUE C IF(IBUGG3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DP3DP1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPLOTV,NPLOTP,NS 52 FORMAT('NPLOTV,NPLOTP,NS = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGG3,IBUGQ 54 FORMAT('IBUGG3,IBUGQ = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IFOUND,IERROR 55 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)MAXNPP 56 FORMAT('MAXNPP = ',I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C ISTEPN='10' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ******************************************** C ** STEP 11-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='11' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHVERT=IHARG(1) IHVER2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHVERT,IHVER2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IVAV=IVALUE(ILOCV) NLOCAL=IN(ILOCV) C IF(IBUGG3.EQ.'ON')WRITE(ICOUT,1107)IHVERT,IHVER2,ILOCV,IERROR, 1IVAV,NLOCAL 1107 FORMAT('IHVERT,IHVER2,ILOCV,IERROR,IVAV,NLOCAL = ', 1A4,A4,2X,I8,2X,A4,I8,I8) IF(IBUGG3.EQ.'ON')CALL DPWRST('XXX','BUG ') C C ***************************************** C ** STEP 12-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='12' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO1290 DO1200J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO1210 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO1210 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO1220 1200 CONTINUE GOTO1290 1210 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO1290 1220 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO1290 1290 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO1295 WRITE(ICOUT,1291)NUMARG,ILOCQ 1291 FORMAT('NUMARG,ILOCQ = ',12I8) CALL DPWRST('XXX','BUG ') 1295 CONTINUE C C ********************************************* C ** STEP 13-- ** C ** FORM THE VECTOR ISUB(.) ** C ** DEPENDING ON THE TYPE OF CASE ** C ** FOR THE QUALIFIER. ** C ********************************************* C ISTEPN='13' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO1310 IF(ICASEQ.EQ.'SUBS')GOTO1320 IF(ICASEQ.EQ.'FOR')GOTO1330 C 1310 CONTINUE DO1315I=1,NLOCAL ISUB(I)=1 1315 CONTINUE NQ=NLOCAL GOTO1350 C 1320 CONTINUE NIOLD=NLOCAL CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4) NQ=NIOLD GOTO1350 C 1330 CONTINUE NIOLD=NLOCAL CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERRO4) NQ=NFOR GOTO1350 C 1350 CONTINUE C C ********************************************************** C ** STEP 14-- ** C ** BRANCH ACCORDING TO THE NUMBER OF ARGUMENTS BEFORE ** C ** 'SUBS', 'FOR', AND 'AND'. ** C ********************************************************** C ISTEPN='14' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ILOCA=NUMARG+1 IF(IHARG(NUMARG).EQ.'AND')ILOCA=NUMARG IF(ILOCA.LT.ILOCQ)NUMAR1=ILOCA-1 IF(ILOCQ.LT.ILOCA)NUMAR1=ILOCQ-1 IF(ILOCA.EQ.ILOCQ)NUMAR1=NUMARG IF(NUMAR1.EQ.3)GOTO1700 IF(NUMAR1.EQ.4)GOTO1800 WRITE(ICOUT,1401) 1401 FORMAT('***** ERROR IN DP3DP1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1402) 1402 FORMAT(' NUMAR1 NOT = 3 OR 4. ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1403)NUMAR1 1403 FORMAT(' NUMAR1 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1404)NUMARG,IHARG(NUMARG),ILOCA,ILOCQ 1404 FORMAT(' NUMARG,IHARG(NUMARG),ILOCA,ILOCQ = ', 1I6,2X,A4,2I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1408) 1408 FORMAT(' THE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1409)(IANS(I),I=1,IWIDTH) 1409 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C C ************************************************************* C ** STEP 17-- ** C ** TREAT THE 3 VARIABLE CASE (WITH NO VS AND NO =) CASE. ** C ************************************************************* C 1700 CONTINUE ISTEPN='17' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C **************************************** C ** STEP 17.1-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C **************************************** C ISTEPN='17.1' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHVERT=IHARG(1) IHVER2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHVERT,IHVER2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IVAV=IVALUE(ILOCV) C C **************************************** C ** STEP 17.2-- ** C ** CHECK THE VALIDITY OF ARGUMENT 2 ** C **************************************** C ISTEPN='17.2' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHHOR=IHARG(2) IHHOR2=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHHOR,IHHOR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCH,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHAV=IVALUE(ILOCH) C C **************************************** C ** STEP 17.3-- ** C ** CHECK THE VALIDITY OF ARGUMENT 3 ** C **************************************** C ISTEPN='17.3' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHHO2=IHARG(3) IHHO22=IHARG2(3) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHHO2,IHHO22,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCH2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHAV2=IVALUE(ILOCH2) C C ************************************************************* C ** STEP 17.4-- ** C ** FORM THE VERTICAL AND 2 HORIZONTAL AXIS ** C ** VARIABLES (Y(.)AND X(.) AND X3D(.), RESPECTIVELY) ** C ** FOR THE PLOT. ** C ** RESET THE D(.) VECTOR TO ONES. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ************************************************************* C ISTEPN='17.4' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IAND1.EQ.'NO')GOTO1719 IF(NPLOTP.LE.0)GOTO1719 D1MAX=D(1) DO1710I=1,NPLOTP IF(D(I).GT.D1MAX)D1MAX=D(I) 1710 CONTINUE D2MIN=1.0 IF(IAND1.EQ.'YES')DEL=D1MAX-D2MIN+1.0 1719 CONTINUE C L=NPLOTP C NLOCAL=IN(ILOCV) DO1720I=1,NLOCAL IF(ISUB(I).EQ.0)GOTO1720 L=L+1 C IF(L.LE.MAXNPP)GOTO1729 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1721) 1721 FORMAT('***** ERROR IN DP3DP1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1723) 1723 FORMAT(' THE NUMBER OF PLOT POINTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1724)MAXNPP 1724 FORMAT(' HAS JUST EXCEEDED ',I8,' *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1725)I,NLOCAL,L,MAXN,MAXNPP,NPLOTP 1725 FORMAT('I,NLOCAL,L,MAXN,MAXNPP,NPLOTP = ',6I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1726)IAND1,IAND2,IFOUND,IERROR 1726 FORMAT('IAND1,IAND2,IFOUND,IERROR = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') GOTO9000 1729 CONTINUE C IJ=MAXN*(IVAV-1)+I IF(IVAV.LE.MAXCOL)Y(L)=V(IJ) IF(IVAV.EQ.MAXCP1)Y(L)=PRED(I) IF(IVAV.EQ.MAXCP2)Y(L)=RES(I) IF(IVAV.EQ.MAXCP3)Y(L)=YPLOT(I) IF(IVAV.EQ.MAXCP4)Y(L)=XPLOT(I) IF(IVAV.EQ.MAXCP5)Y(L)=X2PLOT(I) IF(IVAV.EQ.MAXCP6)Y(L)=TAGPLO(I) IJ=MAXN*(IHAV-1)+I IF(IHAV.LE.MAXCOL)X(L)=V(IJ) IF(IHAV.EQ.MAXCP1)X(L)=PRED(I) IF(IHAV.EQ.MAXCP2)X(L)=RES(I) IF(IHAV.EQ.MAXCP3)X(L)=YPLOT(I) IF(IHAV.EQ.MAXCP4)X(L)=XPLOT(I) IF(IHAV.EQ.MAXCP5)X(L)=X2PLOT(I) IF(IHAV.EQ.MAXCP6)X(L)=TAGPLO(I) IJ=MAXN*(IHAV2-1)+I IF(IHAV2.LE.MAXCOL)X3D(L)=V(IJ) IF(IHAV2.EQ.MAXCP1)X3D(L)=PRED(I) IF(IHAV2.EQ.MAXCP2)X3D(L)=RES(I) IF(IHAV2.EQ.MAXCP3)X3D(L)=YPLOT(I) IF(IHAV2.EQ.MAXCP4)X3D(L)=XPLOT(I) IF(IHAV2.EQ.MAXCP5)X3D(L)=X2PLOT(I) IF(IHAV2.EQ.MAXCP6)X3D(L)=TAGPLO(I) IF(IAND1.EQ.'NO')D(L)=1.0 IF(IAND1.EQ.'YES')D(L)=1.0+DEL 1720 CONTINUE NPLOTP=L NPLOTV=2 IF(IAND1.EQ.'YES'.AND.NPLOTV.GT.2)NPLOTV=NPLOTV GOTO9000 C C C ************************************************************* C ** STEP 18-- ** C ** TREAT THE 4 VARIABLE CASE (WITH NO VS AND NO =) CASE. ** C ************************************************************* C 1800 CONTINUE ISTEPN='18' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C **************************************** C ** STEP 18.1-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C **************************************** C ISTEPN='18.1' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHVERT=IHARG(1) IHVER2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHVERT,IHVER2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IVAV=IVALUE(ILOCV) C C **************************************** C ** STEP 18.2-- ** C ** CHECK THE VALIDITY OF ARGUMENT 2 ** C **************************************** C ISTEPN='18.2' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHHOR=IHARG(2) IHHOR2=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHHOR,IHHOR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCH,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHAV=IVALUE(ILOCH) C C **************************************** C ** STEP 18.3-- ** C ** CHECK THE VALIDITY OF ARGUMENT 3 ** C **************************************** C ISTEPN='18.3' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHHO2=IHARG(3) IHHO22=IHARG2(3) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHHO2,IHHO22,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCH2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHAV2=IVALUE(ILOCH2) C C **************************************** C ** STEP 18.4-- ** C ** CHECK THE VALIDITY OF ARGUMENT 4 ** C **************************************** C ISTEPN='18.4' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHSET=IHARG(4) IHSET2=IHARG2(4) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHSET,IHSET2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCD,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ISETV=IVALUE(ILOCD) C C ************************************************************* C ** STEP 18.5-- ** C ** FORM THE VERTICAL AND 2 HORIZONTAL AXIS ** C ** VARIABLES (Y(.)AND X(.) AND X3D(.), RESPECTIVELY) ** C ** FOR THE PLOT. ** C ** RESET THE D(.) VECTOR TO ONES. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ************************************************************* C ISTEPN='18.5' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IAND1.EQ.'NO')GOTO1819 IF(NPLOTP.LE.0)GOTO1819 D1MAX=D(1) DO1810I=1,NPLOTP IF(D(I).GT.D1MAX)D1MAX=D(I) 1810 CONTINUE I=1 IJ=MAXN*(ISETV-1)+I IF(ISETV.LE.MAXCOL)D2MIN=V(IJ) IF(ISETV.EQ.MAXCP1)D2MIN=PRED(I) IF(ISETV.EQ.MAXCP2)D2MIN=RES(I) IF(ISETV.EQ.MAXCP3)D2MIN=YPLOT(I) IF(ISETV.EQ.MAXCP4)D2MIN=XPLOT(I) IF(ISETV.EQ.MAXCP5)D2MIN=X2PLOT(I) IF(ISETV.EQ.MAXCP6)D2MIN=TAGPLO(I) NLOCAL=IN(ILOCV) DO1811I=1,NLOCAL IJ=MAXN*(ISETV-1)+I IF(ISETV.LE.MAXCOL)GOTO1812 IF(ISETV.EQ.MAXCP1)GOTO1813 IF(ISETV.EQ.MAXCP2)GOTO1814 IF(ISETV.EQ.MAXCP3)GOTO1815 IF(ISETV.EQ.MAXCP4)GOTO1816 IF(ISETV.EQ.MAXCP5)GOTO1817 IF(ISETV.EQ.MAXCP6)GOTO1818 1812 CONTINUE IF(V(IJ).LT.D2MIN)D2MIN=V(IJ) GOTO1811 1813 CONTINUE IF(PRED(I).LT.D2MIN)D2MIN=PRED(I) GOTO1811 1814 CONTINUE IF(RES(I).LT.D2MIN)D2MIN=RES(I) GOTO1811 1815 CONTINUE IF(YPLOT(I).LT.D2MIN)D2MIN=YPLOT(I) GOTO1811 1816 CONTINUE IF(XPLOT(I).LT.D2MIN)D2MIN=XPLOT(I) GOTO1811 1817 CONTINUE IF(X2PLOT(I).LT.D2MIN)D2MIN=X2PLOT(I) GOTO1811 1818 CONTINUE IF(TAGPLO(I).LT.D2MIN)D2MIN=TAGPLO(I) GOTO1811 1811 CONTINUE IF(IAND1.EQ.'YES')DEL=D1MAX-D2MIN+1.0 1819 CONTINUE C L=NPLOTP C NLOCAL=IN(ILOCV) DO1820I=1,NLOCAL IF(ISUB(I).EQ.0)GOTO1820 L=L+1 C IF(L.LE.MAXNPP)GOTO1829 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1821) 1821 FORMAT('***** ERROR IN DP3DP1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1823) 1823 FORMAT(' THE NUMBER OF PLOT POINTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1824)MAXNPP 1824 FORMAT(' HAS JUST EXCEEDED ',I8,' *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1825)I,NLOCAL,L,MAXN,MAXNPP,NPLOTP 1825 FORMAT('I,NLOCAL,L,MAXN,MAXNPP,NPLOTP = ',6I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1826)IAND1,IAND2,IFOUND,IERROR 1826 FORMAT('IAND1,IAND2,IFOUND,IERROR = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') GOTO9000 1829 CONTINUE C IJ=MAXN*(IVAV-1)+I IF(IVAV.LE.MAXCOL)Y(L)=V(IJ) IF(IVAV.EQ.MAXCP1)Y(L)=PRED(I) IF(IVAV.EQ.MAXCP2)Y(L)=RES(I) IF(IVAV.EQ.MAXCP3)Y(L)=YPLOT(I) IF(IVAV.EQ.MAXCP4)Y(L)=XPLOT(I) IF(IVAV.EQ.MAXCP5)Y(L)=X2PLOT(I) IF(IVAV.EQ.MAXCP6)Y(L)=TAGPLO(I) IJ=MAXN*(IHAV-1)+I IF(IHAV.LE.MAXCOL)X(L)=V(IJ) IF(IHAV.EQ.MAXCP1)X(L)=PRED(I) IF(IHAV.EQ.MAXCP2)X(L)=RES(I) IF(IHAV.EQ.MAXCP3)X(L)=YPLOT(I) IF(IHAV.EQ.MAXCP4)X(L)=XPLOT(I) IF(IHAV.EQ.MAXCP5)X(L)=X2PLOT(I) IF(IHAV.EQ.MAXCP6)X(L)=TAGPLO(I) IJ=MAXN*(IHAV2-1)+I IF(IHAV2.LE.MAXCOL)X3D(L)=V(IJ) IF(IHAV2.EQ.MAXCP1)X3D(L)=PRED(I) IF(IHAV2.EQ.MAXCP2)X3D(L)=RES(I) IF(IHAV2.EQ.MAXCP3)X3D(L)=YPLOT(I) IF(IHAV2.EQ.MAXCP4)X3D(L)=XPLOT(I) IF(IHAV2.EQ.MAXCP5)X3D(L)=X2PLOT(I) IF(IHAV2.EQ.MAXCP6)X3D(L)=TAGPLO(I) IJ=MAXN*(ISETV-1)+I IF(IAND1.EQ.'NO'.AND.ISETV.LE.MAXCOL)D(L)=V(IJ) IF(IAND1.EQ.'NO'.AND.ISETV.EQ.MAXCP1)D(L)=PRED(I) IF(IAND1.EQ.'NO'.AND.ISETV.EQ.MAXCP2)D(L)=RES(I) IF(IAND1.EQ.'NO'.AND.ISETV.EQ.MAXCP3)D(L)=YPLOT(I) IF(IAND1.EQ.'NO'.AND.ISETV.EQ.MAXCP4)D(L)=XPLOT(I) IF(IAND1.EQ.'NO'.AND.ISETV.EQ.MAXCP5)D(L)=X2PLOT(I) IF(IAND1.EQ.'NO'.AND.ISETV.EQ.MAXCP6)D(L)=TAGPLO(I) IF(IAND1.EQ.'YES'.AND.ISETV.LE.MAXCOL)D(L)=V(IJ)+DEL IF(IAND1.EQ.'YES'.AND.ISETV.EQ.MAXCP1)D(L)=PRED(I)+DEL IF(IAND1.EQ.'YES'.AND.ISETV.EQ.MAXCP2)D(L)=RES(I)+DEL IF(IAND1.EQ.'YES'.AND.ISETV.EQ.MAXCP3)D(L)=YPLOT(I)+DEL IF(IAND1.EQ.'YES'.AND.ISETV.EQ.MAXCP4)D(L)=XPLOT(I)+DEL IF(IAND1.EQ.'YES'.AND.ISETV.EQ.MAXCP5)D(L)=X2PLOT(I)+DEL IF(IAND1.EQ.'YES'.AND.ISETV.EQ.MAXCP6)D(L)=TAGPLO(I)+DEL 1820 CONTINUE NPLOTP=L NPLOTV=3 IF(IAND1.EQ.'YES'.AND.NPLOTV.GT.3)NPLOTV=NPLOTV GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DP3DP1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IBUGG3,IBUGQ 9014 FORMAT('IBUGG3,IBUGQ = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IFOUND,IERROR 9015 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)MAXNPP 9016 FORMAT('MAXNPP = ',I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DP3DP2(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IVSLOC,NUMVS, 1MAXNPP, 1IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--FORM VARIOUS 3-DIMENSIONAL PLOTS C WHEN HAVE 1 OR MORE VERSUS ENTERED. 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-921-3651 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--DECEMBER 1977. C UPDATED --JANUARY 1978. C UPDATED --FEBRUARY 1978. C UPDATED --MAY 1978. C UPDATED --JUNE 1978. C UPDATED --JULY 1978. C UPDATED --NOVEMBER 1978. C UPDATED --FEBRUARY 1979. C UPDATED --MARCH 1979. C UPDATED --JULY 1979. C UPDATED --JANUARY 1981. C UPDATED --FEBRUARY 1981. C UPDATED --OCTOBER 1981. C UPDATED --NOVEMBER 1981. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ICASEQ CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 IHVERT CHARACTER*4 IHVER2 CHARACTER*4 IHHOR CHARACTER*4 IHHOR2 CHARACTER*4 IHHO2 CHARACTER*4 IHHO22 CHARACTER*4 IERRO4 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION IVSLOC(100) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.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='DP3D' ISUBN2='P2 ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C CCCCC MAXNPP=1000 C KSTART=0 C DEL=0.0 C C *********************************************************** C ** STEP 20-- ** C ** TREAT THE CASE WHEN HAVE 1 OR MORE 'VERSUS' ENTERED ** C *********************************************************** C 2000 CONTINUE C IF(IBUGG3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DP3DP2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPLOTV,NPLOTP,NS 52 FORMAT('NPLOTV,NPLOTP,NS = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGG3,IBUGQ 54 FORMAT('IBUGG3,IBUGQ = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IFOUND,IERROR 55 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)MAXNPP 56 FORMAT('MAXNPP = ',I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C ISTEPN='20' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ***************************************** C ** STEP 21-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='21' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO2190 DO2100J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO2110 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO2110 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO2120 2100 CONTINUE GOTO2190 2110 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO2190 2120 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO2190 2190 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO2195 WRITE(ICOUT,2191)NUMARG,ILOCQ 2191 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 2195 CONTINUE C C ********************************** C ** STEP 22-- ** C ** DETERMINE WHICH VARIABLES ** C ** ARE TO BE GROUPED TOGETHER ** C ********************************** C ISTEPN='22' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C L=NPLOTP C NEWSET=0 DO2200J=1,NUMVS JM1=J-1 IF(J.EQ.1)KSTART=1 IF(J.GE.2)KSTART=IVSLOC(JM1)+3 KSTOP=IVSLOC(J)-1 IVS=IVSLOC(J) C IVSP1=IVS+1 IVSP2=IVS+2 DO2210K=KSTART,KSTOP NEWSET=NEWSET+1 C IHVERT=IHARG(K) IHVER2=IHARG2(K) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHVERT,IHVER2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IVAV=IVALUE(ILOCV) NLOCAL=IN(ILOCV) C IHHOR=IHARG(IVSP1) IHHOR2=IHARG2(IVSP1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHHOR,IHHOR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCH,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHAV=IVALUE(ILOCH) C IHHO2=IHARG(IVSP2) IHHO22=IHARG2(IVSP2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHHO2,IHHO22,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCH2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHAV2=IVALUE(ILOCH2) C ISETV=NEWSET C IF(IAND1.EQ.'NO')GOTO2280 IF(NPLOTP.LE.0)GOTO2280 D1MAX=D(1) DO2220I=1,NPLOTP IF(D(I).GT.D1MAX)D1MAX=D(I) 2220 CONTINUE D2MIN=1.0 IF(IAND1.EQ.'YES')DEL=D1MAX-D2MIN+1.0 2280 CONTINUE C IF(IBUGG3.EQ.'OFF')GOTO2289 WRITE(ICOUT,2282)IHVERT,ILOCV,IERROR,IVAV,NLOCAL 2282 FORMAT('IHVERT,ILOCV,IERROR,IVAV,NLOCAL = ', 1A4,2X,I8,2X,A4,2X,2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2283)IHHOR,ILOCH,IERROR,IHAV,NLOCAL 2283 FORMAT('IHHOR,ILOCH,IERROR,IHAV,NLOCAL = ', 1A4,2X,I8,2X,A4,2X,2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2284)IHHOR2,ILOCH2,IERROR,IHAV2,NLOCAL 2284 FORMAT('IHHOR2,ILOCH2,IERROR,IHAV2,NLOCAL = ', 1A4,2X,I8,2X,A4,2X,2I8) CALL DPWRST('XXX','BUG ') 2289 CONTINUE C C ********************************************* C ** STEP 23-- ** C ** FORM THE VECTOR ISUB(.) ** C ** DEPENDING ON THE TYPE OF CASE ** C ** FOR THE QUALIFIER. ** C ** BRANCH TO THE PRPPER CASE. ** C ********************************************* C ISTEPN='23' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO2310 IF(ICASEQ.EQ.'SUBS')GOTO2320 IF(ICASEQ.EQ.'FOR')GOTO2330 CCCCC IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO2320 CCCCC IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO2320 CCCCC IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO2330 C 2310 CONTINUE DO2315I=1,NLOCAL ISUB(I)=1 2315 CONTINUE NQ=NLOCAL GOTO2350 C 2320 CONTINUE NIOLD=NLOCAL CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4) NQ=NIOLD GOTO2350 C 2330 CONTINUE NIOLD=NLOCAL CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERRO4) NQ=NFOR GOTO2350 C 2350 CONTINUE C DO2360I=1,NLOCAL IF(ISUB(I).EQ.0)GOTO2360 L=L+1 C IF(L.LE.MAXNPP)GOTO2369 WRITE(ICOUT,2362) 2362 FORMAT('***** PLOT FORMATION ERROR IN DP3DP2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2363) 2363 FORMAT(' THE NUMBER OF PLOT POINTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2364)MAXNPP 2364 FORMAT(' HAS JUST EXCEEDED ',I8,' *****') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2369 CONTINUE C IJ=MAXN*(IVAV-1)+I IF(IVAV.LE.MAXCOL)Y(L)=V(IJ) IF(IVAV.EQ.MAXCP1)Y(L)=PRED(I) IF(IVAV.EQ.MAXCP2)Y(L)=RES(I) IF(IVAV.EQ.MAXCP3)Y(L)=YPLOT(I) IF(IVAV.EQ.MAXCP4)Y(L)=XPLOT(I) IF(IVAV.EQ.MAXCP5)Y(L)=X2PLOT(I) IF(IVAV.EQ.MAXCP6)Y(L)=TAGPLO(I) IJ=MAXN*(IHAV-1)+I IF(IHAV.LE.MAXCOL)X(L)=V(IJ) IF(IHAV.EQ.MAXCP1)X(L)=PRED(I) IF(IHAV.EQ.MAXCP2)X(L)=RES(I) IF(IHAV.EQ.MAXCP3)X(L)=YPLOT(I) IF(IHAV.EQ.MAXCP4)X(L)=XPLOT(I) IF(IHAV.EQ.MAXCP5)X(L)=X2PLOT(I) IF(IHAV.EQ.MAXCP6)X(L)=TAGPLO(I) IJ=MAXN*(IHAV2-1)+I IF(IHAV2.LE.MAXCOL)X3D(L)=V(IJ) IF(IHAV2.EQ.MAXCP1)X3D(L)=PRED(I) IF(IHAV2.EQ.MAXCP2)X3D(L)=RES(I) IF(IHAV2.EQ.MAXCP3)X3D(L)=YPLOT(I) IF(IHAV2.EQ.MAXCP4)X3D(L)=XPLOT(I) IF(IHAV2.EQ.MAXCP5)X3D(L)=X2PLOT(I) IF(IHAV2.EQ.MAXCP6)X3D(L)=TAGPLO(I) IF(IAND1.EQ.'NO')D(L)=ISETV IF(IAND1.EQ.'YES')D(L)=ISETV+DEL 2360 CONTINUE 2210 CONTINUE 2200 CONTINUE NPLOTP=L C DHOLD=D(1) DO2370I=1,NPLOTP IF(D(I).NE.DHOLD)GOTO2375 2370 CONTINUE NPLOTV=2 GOTO2399 2375 CONTINUE NPLOTV=3 GOTO2399 C 2399 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPPLO1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IBUGG3,IBUGQ 9014 FORMAT('IBUGG3,IBUGQ = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IFOUND,IERROR 9015 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9026)MAXNPP 9026 FORMAT('MAXNPP = ',I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DP3DP3(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1PARAM,IPARN,IPARN2,NUMPAR,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD, 1IFOLOC, 1MAXNPP, 1IANGLU,IBUGG3,IBUGCO,IBUGEV,IBUGQ,IFOUND,IERROR) C C PURPOSE--FORM THE 3-DIMENSIONAL PLOT OF A 2-VARIABLE FUNCTION C (THAT IS, FORM TRACES FROM A SURFACE) C WHEN HAVE 1 OR MORE = ENTERED, C THAT IS, WHEN HAVE PLOT Y = ... FOR 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-921-3651 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 1981. C UPDATED --AUGUST 1981. C UPDATED --OCTOBER 1981. C UPDATED --NOVEMBER 1981. C UPDATED --DECEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --APRIL 1992. FIX PLOT CONSTANT C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IPARN CHARACTER*4 IPARN2 CHARACTER*4 ITYPEH CHARACTER*4 IW2HOL CHARACTER*4 IW22HO CHARACTER*4 IANGLU CHARACTER*4 IBUGG3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 IWD1 CHARACTER*4 IWD12 CHARACTER*4 IWD2 CHARACTER*4 IWD22 CHARACTER*4 IVERTI CHARACTER*4 IVDU11 CHARACTER*4 IVDU12 CHARACTER*4 IVDU21 CHARACTER*4 IVDU22 CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IHPARN CHARACTER*4 IHPAR2 CCCCC CHARACTER*4 IA C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C C--------------------------------------------------------------------- C DIMENSION PARAM(*) DIMENSION IPARN(*) DIMENSION IPARN2(*) C DIMENSION ITYPEH(*) DIMENSION IW2HOL(*) DIMENSION IW22HO(*) DIMENSION W2HOLD(*) C DIMENSION IFOLOC(*) C CCCCC DIMENSION IA(132) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.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='DP3D' ISUBN2='P3 ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C CCCCC MAXNPP=1000 C NUMIT1=1 NUMIT2=0 LOCDU1=0 LOCDU2=0 I2=0 I2M1=0 C DEL=0.0 C C ************************************************************** C ** TREAT THE CASE WHEN HAVE 1 OR MORE '=' ENTERED C ** THAT IS, TREAT THE 3D-PLOT Y = ... FOR X = ... CASE C ************************************************************** C 3000 CONTINUE C IF(IBUGG3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DP3DP3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPLOTV,NPLOTP,NS,MAXNPP 52 FORMAT('NPLOTV,NPLOTP,NS,MAXNPP = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IANGLU,IBUGG3,IBUGCO,IBUGEV,IBUGQ 54 FORMAT('IANGLU,IBUGG3,IBUGCO,IBUGEV,IBUGQ = ', 1A4,2X,A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IFOUND,IERROR 55 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************************* C ** STEP 2-- ** C ** DETERMINE THE MAX TRACE DESIGNATION ** C ** (A NUMBER) AS CONTAINED ** C ** IN THE VECTOR D(.). ** C ******************************************* C ISTEPN='2' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IAND1.EQ.'NO')GOTO119 IF(NPLOTP.LE.0)GOTO119 D1MAX=D(1) DO110I=1,NPLOTP IF(D(I).GT.D1MAX)D1MAX=D(I) 110 CONTINUE D2MIN=1.0 IF(IAND1.EQ.'YES')DEL=D1MAX-D2MIN+1.0 119 CONTINUE C C ******************************************************* C ** STEP 3-- ** C ** DETERMINE THE NAME OF THE FIRST DUMMY VARIABLE ** C ** (IT NEVER GETS STORED PERMANENTLY) ** C ** IMMEDIATELY FOLLOWING THE FIRST 'FOR' KEYWORD ** C ******************************************************* C ISTEPN='3' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO3100J=1,NUMARG J2=J IF(IHARG(J).EQ.'FOR')GOTO3119 3100 CONTINUE 3109 CONTINUE C IBRAN=3111 WRITE(ICOUT,3111) 3111 FORMAT('***** ERROR IN DP3DP3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3112) 3112 FORMAT(' THE FIRST FOR NOT FOUND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3113) 3113 FORMAT(' EVEN THOUGH THE STRING = WAS FOUND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3114) 3114 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3115)(IANS(I),I=1,IWIDTH) 3115 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 3119 CONTINUE IFOLP0=J2 C IF(IFOLP0.LT.NUMARG)GOTO3139 WRITE(ICOUT,3121) 3121 FORMAT('***** ERROR IN DP3DP3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3122) 3122 FORMAT(' THE FIRST FOR WAS THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3123) 3123 FORMAT(' FINAL WORD ON THE COMMAND LINE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3124) 3124 FORMAT(' THE WORD FOR SHOULD HAVE BEEN FOLLOWED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3125) 3125 FORMAT(' BY 11 WORDS --') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3126) 3126 FORMAT(' 1) A DUMMY VARIABLE NAME;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3127) 3127 FORMAT(' 2) AN EQUAL SIGN;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3128) 3128 FORMAT(' 3) ONE LIMIT (LOWER OR UPPER) ', 1'FOR THE DUMMY VARIABLE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3129) 3129 FORMAT(' 4) THE INCREMENT FOR THE DUMMY VARIABLE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3130) 3130 FORMAT(' 5) THE OTHER LIMIT (UPPER OR LOWER) ', 1'FOR THE DUMMY VARIABLE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3131) 3131 FORMAT(' 6) THE SECOND FOR AND ITS 5 WORDS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3132) 3132 FORMAT(' (DUMMY NAME, EQUAL SIGN, LOWER, INCREMENT,', 1' UPPER)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3136) 3136 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3137)(IANS(I),I=1,IWIDTH) 3137 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 3139 CONTINUE IFOLP1=IFOLP0+1 IVDU11=IHARG(IFOLP1) IVDU12=IHARG2(IFOLP1) C C ******************************************************* C ** STEP 3.1-- ** C ** DETERMINE THE NAME OF THE SECOND DUMMY VARIABLE ** C ** (IT NEVER GETS STORED PERMANENTLY) ** C ** IMMEDIATELY FOLLOWING THE SECOND 'FOR' KEYWORD ** C ******************************************************* C ISTEPN='3.1' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IFOLP6=IFOLP0+6 IF(IFOLP6.GT.NUMARG)GOTO3159 DO3150J=IFOLP6,NUMARG J2=J IF(IHARG(J).EQ.'FOR')GOTO3169 3150 CONTINUE 3159 CONTINUE C IBRAN=3161 WRITE(ICOUT,3161) 3161 FORMAT('***** ERROR IN DP3DP3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3162) 3162 FORMAT(' THE SECOND FOR NOT FOUND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3163) 3163 FORMAT(' EVEN THOUGH THE STRING = WAS FOUND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3164) 3164 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3165)(IANS(I),I=1,IWIDTH) 3165 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 3169 CONTINUE IF2LOC=J2 C IF(IFOLP0.LT.NUMARG)GOTO3189 WRITE(ICOUT,3171) 3171 FORMAT('***** ERROR IN DP3DP3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3172) 3172 FORMAT(' THE SECOND FOR WAS THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3173) 3173 FORMAT(' FINAL WORD ON THE COMMAND LINE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3174) 3174 FORMAT(' THE WORD FOR SHOULD HAVE BEEN FOLLOWED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3175) 3175 FORMAT(' BY 5 WORDS --') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3176) 3176 FORMAT(' 1) A DUMMY VARIABLE NAME;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3177) 3177 FORMAT(' 2) AN EQUAL SIGN;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3178) 3178 FORMAT(' 3) ONE LIMIT (LOWER OR UPPER) ', 1'FOR THE DUMMY VARIABLE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3179) 3179 FORMAT(' 4) THE INCREMENT FOR THE DUMMY VARIABLE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3180) 3180 FORMAT(' 5) THE OTHER LIMIT (UPPER OR LOWER) ', 1'FOR THE DUMMY VARIABLE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3186) 3186 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3187)(IANS(I),I=1,IWIDTH) 3187 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 3189 CONTINUE IF2LP1=IF2LOC+1 IVDU21=IHARG(IF2LP1) IVDU22=IHARG2(IF2LP1) C C ******************************************* C ** STEP 4-- ** C ** EVALUATE THE FUNCTION OVER ** C ** THE VARIOUS POINTS IN THE INTERVAL. ** C ******************************************* C ISTEPN='4' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMAM1=NUMARG-1 NUMAM2=NUMARG-2 NUMAM3=NUMARG-3 NUMAM6=NUMARG-6 NUMAM7=NUMARG-7 NUMAM8=NUMARG-8 NUMAM9=NUMARG-9 C 3210 CONTINUE ILOCA=NUMAM8 IF(IHARG(NUMARG).EQ.'AND')ILOCA=NUMAM9 IF(IARGT(ILOCA).EQ.'NUMB')GOTO3211 IF(IARGT(ILOCA).EQ.'WORD')GOTO3212 GOTO3270 3211 CONTINUE START1=ARG(ILOCA) GOTO3219 3212 CONTINUE IH=IHARG(ILOCA) IH2=IHARG2(ILOCA) IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 START1=VALUE(ILOC) 3219 CONTINUE C 3220 CONTINUE ILOCA=NUMAM7 IF(IHARG(NUMARG).EQ.'AND')ILOCA=NUMAM8 IF(IARGT(ILOCA).EQ.'NUMB')GOTO3221 IF(IARGT(ILOCA).EQ.'WORD')GOTO3222 GOTO3270 3221 CONTINUE AINC1=ARG(ILOCA) GOTO3229 3222 CONTINUE IH=IHARG(ILOCA) IH2=IHARG2(ILOCA) IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 AINC1=VALUE(ILOC) 3229 CONTINUE C 3230 CONTINUE ILOCA=NUMAM6 IF(IHARG(NUMARG).EQ.'AND')ILOCA=NUMAM7 IF(IARGT(ILOCA).EQ.'NUMB')GOTO3231 IF(IARGT(ILOCA).EQ.'WORD')GOTO3232 GOTO3270 3231 CONTINUE STOP1=ARG(ILOCA) GOTO3239 3232 CONTINUE IH=IHARG(ILOCA) IH2=IHARG2(ILOCA) IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 STOP1=VALUE(ILOC) 3239 CONTINUE C 3240 CONTINUE ILOCA=NUMAM2 IF(IHARG(NUMARG).EQ.'AND')ILOCA=NUMAM3 IF(IARGT(ILOCA).EQ.'NUMB')GOTO3241 IF(IARGT(ILOCA).EQ.'WORD')GOTO3242 GOTO3270 3241 CONTINUE START2=ARG(ILOCA) GOTO3249 3242 CONTINUE IH=IHARG(ILOCA) IH2=IHARG2(ILOCA) IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 START2=VALUE(ILOC) 3249 CONTINUE C 3250 CONTINUE ILOCA=NUMAM1 IF(IHARG(NUMARG).EQ.'AND')ILOCA=NUMAM2 IF(IARGT(ILOCA).EQ.'NUMB')GOTO3251 IF(IARGT(ILOCA).EQ.'WORD')GOTO3252 GOTO3270 3251 CONTINUE AINC2=ARG(ILOCA) GOTO3259 3252 CONTINUE IH=IHARG(ILOCA) IH2=IHARG2(ILOCA) IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 AINC2=VALUE(ILOC) 3259 CONTINUE C 3260 CONTINUE ILOCA=NUMARG IF(IHARG(NUMARG).EQ.'AND')ILOCA=NUMAM1 IF(IARGT(ILOCA).EQ.'NUMB')GOTO3261 IF(IARGT(ILOCA).EQ.'WORD')GOTO3262 GOTO3270 3261 CONTINUE STOP2=ARG(ILOCA) GOTO3269 3262 CONTINUE IH=IHARG(ILOCA) IH2=IHARG2(ILOCA) IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 STOP2=VALUE(ILOC) 3269 CONTINUE C GOTO3280 C 3270 CONTINUE WRITE(ICOUT,3271) 3271 FORMAT('***** INTERNAL ERROR IN DP3DP3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3272) 3272 FORMAT(' AN ARGUMENT TYPE WHICH SHOULD BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3273) 3273 FORMAT(' EITHER A NUMBER OR A WORD, IS NEITHER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3274)IHARG(ILOCA) 3274 FORMAT(' ARGUMENT = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3275)ILOCA 3275 FORMAT(' LOCATION IN ARGUMENT LIST = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3276)IARGT(ILOCA) 3276 FORMAT(' ARGUMENT TYPE = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3277) 3277 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3278)(IANS(I),I=1,IWIDTH) 3278 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3280 CONTINUE IF(START1.NE.STOP1.AND.AINC1.NE.0.0)GOTO3297 IF(START2.NE.STOP2.AND.AINC2.NE.0.0)GOTO3297 WRITE(ICOUT,3281) 3281 FORMAT('***** NOTE FROM DP3DP3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3282) 3282 FORMAT(' BOTH LOWER AND UPPER LIMITS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3283) 3283 FORMAT(' OF THE FUNCTION INTERVALS OF INTEREST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3284) 3284 FORMAT(' ARE IDENTICAL; OR THE INCREMENT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3285) 3285 FORMAT(' IS IDENTICALLY ZERO.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3286)START1 3286 FORMAT(' FIRST LOWER LIMIT = ',D15.8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3287)AINC1 3287 FORMAT(' FIRST INCREMENT = ',D15.8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3288)STOP1 3288 FORMAT(' FIRST UPPER LIMIT = ',D15.8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3289)START2 3289 FORMAT(' SECOND LOWER LIMIT = ',D15.8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3290)AINC2 3290 FORMAT(' SECOND INCREMENT = ',D15.8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3291)STOP2 3291 FORMAT(' SECOND UPPER LIMIT = ',D15.8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3292) 3292 FORMAT(' THE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3293)(IANS(I),I=1,IWIDTH) 3293 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3294) 3294 FORMAT(' RESULTING ACTION--ONLY A SINGLE POINT ', 1'WAS OUTPUTTED FOR PLOTTING.') CALL DPWRST('XXX','BUG ') NUMIT1=1 GOTO3299 3297 CONTINUE C C *****THE FOLLOWING CORRECTIVE LINE ADDED AUGUST 1983***** IF(START1.EQ.STOP1)AINC1=0.0 IF(START1.LT.STOP1.AND.AINC1.LT.0.0)AINC1=-AINC1 IF(START1.GT.STOP1.AND.AINC1.GT.0.0)AINC1=-AINC1 C *****THE FOLLOWING 2 CORRECTIVE LINES ADDED AUGUST 1983***** IF(AINC1.EQ.0.0)NUMIT1=1 IF(AINC1.NE.0.0)NUMIT1=(STOP1-START1)/AINC1 IF(NUMIT1.LT.0)NUMIT1=-NUMIT1 NUMIT1=NUMIT1+1 C C *****THE FOLLOWING CORRECTIVE LINE ADDED AUGUST 1983***** IF(START2.EQ.STOP2)AINC2=0.0 IF(START2.LT.STOP2.AND.AINC2.LT.0.0)AINC2=-AINC2 IF(START2.GT.STOP2.AND.AINC2.GT.0.0)AINC2=-AINC2 C *****THE FOLLOWING 2 CORRECTIVE LINES ADDED AUGUST 1983***** IF(AINC2.EQ.0.0)NUMIT2=1 IF(AINC2.NE.0.0)NUMIT2=(STOP2-START2)/AINC2 IF(NUMIT2.LT.0)NUMIT2=-NUMIT2 NUMIT2=NUMIT2+1 C 3299 CONTINUE C C *********************************************************** C ** STEP 5-- ** C ** EXTRACT THE FUNCTIONAL ** C ** EXPRESSION FROM THE INPUT COMMAND LINE. ** C *********************************************************** C ISTEPN='5' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MAXN2=MAXCHF MAXN3=MAXCHF MAXN4=MAXCHF C IF(IHARG(2).EQ.'=')IWD1='=' IF(IHARG(2).EQ.'=')IWD12=' ' IF(IHARG(2).NE.'=')IWD1='PLOT' IF(IHARG(2).NE.'=')IWD12=' ' IWD2='FOR' IWD22=' ' CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2, 1IFUNC2,N2F,IBUGG3,IFOUND,IERROR) IF(IERROR.EQ.'YES')RETURN IF(IFOUND.EQ.'YES')GOTO3379 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3371) 3371 FORMAT('***** ERROR IN DP3DP3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3372) 3372 FORMAT(' INVALID COMMAND FORM FOR FUNCTION PLOTTING.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3373) 3373 FORMAT(' GENERAL FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3374) 3374 FORMAT(' PLOT ... = ... ', 1'FOR ... = ... ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3375) 3375 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3376)(IANS(I),I=1,IWIDTH) 3376 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' RETURN 3379 CONTINUE C C *********************************************************** C ** STEP 5.1-- ** C ** FIRST CHECK TO SEE IF HAVE THE VERTICAL LINES CASE; ** C ** THEN EXTRACT THE UNDERLYING FUNCTION FROM ** C ** FUNCTION DEFINITIONS. ** C *********************************************************** C ISTEPN='5.1' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IVERTI='NO' DO3380I=1,NUMARG IF(IHARG(I).EQ.'VERT'.AND.IHARG2(I).EQ.'ICAL')GOTO3385 3380 CONTINUE GOTO3389 3385 CONTINUE C IMAX=N2F-12 IF(IMAX.LE.0)GOTO3389 DO3386I=1,IMAX IP1=I+1 IP2=I+2 IP3=I+3 IP4=I+4 IP5=I+5 IP6=I+6 IP7=I+7 IF(IFUNC2(I).NE.'V')GOTO3386 IF(IFUNC2(IP1).NE.'E')GOTO3386 IF(IFUNC2(IP2).NE.'R')GOTO3386 IF(IFUNC2(IP3).NE.'T')GOTO3386 IF(IFUNC2(IP4).NE.'I')GOTO3386 IF(IFUNC2(IP5).NE.'C')GOTO3386 IF(IFUNC2(IP6).NE.'A')GOTO3386 IF(IFUNC2(IP7).NE.'L')GOTO3386 IVERTI='YES' N2F=I-1 GOTO3389 3386 CONTINUE 3389 CONTINUE C CALL DPEXFU(IFUNC2,N2F,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP, 1NUMNAM,IANS,IWIDTH,IFUNC,NUMCHF,MAXCHF,IFUNC3,N3F,MAXN3, 1IBUGG3,IERROR) IF(IERROR.EQ.'YES')RETURN C CCCCC J=0 CCCCC DO3390I=1,N3F CCCCC J=J+1 CCCCC IA(J)=IFUNC3(I) C3390 CONTINUE CCCCC NUMCHA=J C C ********************************************************** C ** STEP 6-- ** C ** MAKE A NON-CALCULATING PASS AT THE FUNCTION ** C ** SO AS TO EXTRACT ALL PARAMETER AND VARIABLE NAMES. ** C ********************************************************** C ISTEPN='6' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C IPASS=1 CALL COMPIM(IFUNC3,N3F,IPASS,PARAM,IPARN,IPARN2,NUMPV, 1IANGLU,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,AJUNK, 1IBUGCO,IBUGEV,IERROR) IF(IBUGG3.EQ.'ON')WRITE(ICOUT,3411)NUMPV,IPARN(1),IPARN2(1), 1PARAM(1) 3411 FORMAT('NUMPV,IPARN(1),IPARN2(1),PARAM(1) = ', 1I8,2X,A4,2X,A4,E15.7) IF(IBUGG3.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(IERROR.EQ.'YES')GOTO9000 C C *********************************************** C ** STEP 7-- ** C ** CHECK THAT ALL PARAMETERS ** C ** IN THE FUNCTION ARE ALREADY PRESENT ** C ** IN THE AVAILABLE NAME LIST IHNAME(.). ** C ** ALSO CHECK THAT THE VARIABLE NAME ** C ** THAT FOLLOWS FOR (THAT IS, THE DUMMY VARIABLE) ** C ** IS IN THE FUNCTION. ** C *********************************************** C ISTEPN='7' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IP=0 IV=0 IF(NUMPV.LE.0)GOTO3650 DO3600J=1,NUMPV IHPARN=IPARN(J) IHPAR2=IPARN2(J) IF(IHPARN.EQ.IVDU11.AND.IHPAR2.EQ.IVDU12)GOTO3620 IF(IHPARN.EQ.IVDU21.AND.IHPAR2.EQ.IVDU22)GOTO3630 IHWUSE='P' MESSAG='YES' CALL CHECKN(IHPARN,IHPAR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C 3610 CONTINUE IP=IP+1 PARAM(J)=VALUE(ILOCP) GOTO3600 C 3620 CONTINUE IV=IV+1 LOCDU1=J C 3630 CONTINUE IV=IV+1 LOCDU2=J C 3600 CONTINUE 3650 CONTINUE CCCCC THE FOLLOWING 10 LINES WERE ADDED APRIL 1992 (JJF) IF(LOCDU1.LE.0)THEN IV=IV+1 NUMPV=NUMPV+1 LOCDU1=NUMPV ENDIF IF(LOCDU2.LE.0)THEN IV=IV+1 NUMPV=NUMPV+1 LOCDU2=NUMPV ENDIF NUMPAR=IP NUMVAR=IV C C ****************************** C ** STEP 8-- ** C ** EVALUATE THE FUNCTION. ** C ****************************** C ISTEPN='8' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IPASS=2 L=NPLOTP L2=L ISET=0 C DO3810I1=1,NUMIT1 I1M1=I1-1 AI1=I1 RESUL1=START1+(AI1-1.0)*AINC1 C IF(I1.EQ.1)GOTO3819 IF(START1.LT.STOP1.AND.RESUL1.GT.STOP1)GOTO3818 IF(START1.GT.STOP1.AND.RESUL1.LT.STOP1)GOTO3818 3819 CONTINUE ISET=ISET+1 C DO3820I2=1,NUMIT2 I2M1=I2-1 AI2=I2 RESUL2=START2+(AI2-1.0)*AINC2 C IF(I2.EQ.1)GOTO3829 IF(START2.LT.STOP2.AND.RESUL2.GT.STOP2)GOTO3828 IF(START2.GT.STOP2.AND.RESUL2.LT.STOP2)GOTO3828 3829 CONTINUE L2=L2+1 CCCCC WRITE(ICOUT,3823)I1,I2,RESUL1,RESUL2,L,L2,MAXNPP C3823 FORMAT('I1,I2,RESUL1,RESUL2,L,L2,MAXNPP = ',2I8,2F15.7,3I8) CCCCC CALL DPWRST('XXX','BUG ') C IF(L2.LE.MAXNPP)GOTO3839 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3831) 3831 FORMAT('***** PLOT FORMATION ERROR IN DPPLO3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3832) 3832 FORMAT(' THE NUMBER OF PLOT POINTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3833)MAXNPP 3833 FORMAT(' HAS JUST EXCEEDED ',I8,' *****') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 3839 CONTINUE C XTEMP=RESUL1 YTEMP=RESUL2 C PARAM(LOCDU1)=XTEMP PARAM(LOCDU2)=YTEMP CALL COMPIM(IFUNC3,N3F,IPASS,PARAM,IPARN,IPARN2,NUMPV, 1IANGLU,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,ZTEMP, 1IBUGCO,IBUGEV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IF(IVERTI.EQ.'NO')GOTO3849 HOLD=ZTEMP ZTEMP=YTEMP YTEMP=HOLD 3849 CONTINUE C Y(L2)=ZTEMP X(L2)=XTEMP X3D(L2)=YTEMP IF(IAND1.EQ.'NO')D(L2)=ISET IF(IAND1.EQ.'YES')D(L2)=ISET+DEL 3820 CONTINUE 3828 CONTINUE 3810 CONTINUE N2PT1=I2 GOTO3889 3818 CONTINUE N2PT1=I2M1 3889 CONTINUE C DO3910I2=1,NUMIT2 I2M1=I2-1 AI2=I2 RESUL2=START2+(AI2-1.0)*AINC2 C IF(I2.EQ.1)GOTO3919 IF(START2.LT.STOP2.AND.RESUL2.GT.STOP2)GOTO3918 IF(START2.GT.STOP2.AND.RESUL2.LT.STOP2)GOTO3918 3919 CONTINUE ISET=ISET+1 C DO3920I1=1,NUMIT1 I1M1=I1-1 AI1=I1 RESUL1=START1+(AI1-1.0)*AINC1 C IF(I1.EQ.1)GOTO3929 IF(START1.LT.STOP1.AND.RESUL1.GT.STOP1)GOTO3928 IF(START1.GT.STOP1.AND.RESUL1.LT.STOP1)GOTO3928 3929 CONTINUE L2=L2+1 CCCCC WRITE(ICOUT,3923)I1,I2,RESUL1,RESUL2,L,L2,MAXNPP C3923 FORMAT('I1,I2,RESUL1,RESUL2,L,L2,MAXNPP = ',2I8,2F15.7,3I8) CCCCC CALL DPWRST('XXX','BUG ') C IF(L2.LE.MAXNPP)GOTO3939 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3931) 3931 FORMAT('***** PLOT FORMATION ERROR IN DPPLO3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3932) 3932 FORMAT(' THE NUMBER OF PLOT POINTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3933)MAXNPP 3933 FORMAT(' HAS JUST EXCEEDED ',I8,' *****') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 3939 CONTINUE C XTEMP=RESUL1 YTEMP=RESUL2 C PARAM(LOCDU1)=XTEMP PARAM(LOCDU2)=YTEMP CALL COMPIM(IFUNC3,N3F,IPASS,PARAM,IPARN,IPARN2,NUMPV, 1IANGLU,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,ZTEMP, 1IBUGCO,IBUGEV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IF(IVERTI.EQ.'NO')GOTO3949 HOLD=ZTEMP ZTEMP=YTEMP YTEMP=HOLD 3949 CONTINUE C Y(L2)=ZTEMP X(L2)=XTEMP X3D(L2)=YTEMP IF(IAND1.EQ.'NO')D(L2)=ISET IF(IAND1.EQ.'YES')D(L2)=ISET+DEL 3920 CONTINUE 3928 CONTINUE 3910 CONTINUE N2PT2=I2 GOTO3989 3918 CONTINUE N2PT2=I2M1 3989 CONTINUE L=L2 NPLOTP=L N2=N2PT1+N2PT2 C C ***************************** C ** STEP 9-- ** C ** DETERMINE THE NUMBER ** C ** OF PLOT VARIABLES. ** C ** STORE THIS IN NPLOTV. ** C ***************************** C ISTEPN='9' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DHOLD=D(1) DO4830I=1,NPLOTP IF(D(I).NE.DHOLD)GOTO4835 4830 CONTINUE NPLOTV=2 GOTO4890 4835 CONTINUE NPLOTV=3 GOTO4890 C 4890 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DP3DP3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,MAXNPP,ICASPL,IAND1,IAND2 9013 FORMAT('NPLOTV,NPLOTP,NS,MAXNPP,ICASPL,IAND1,IAND2 = ', 14I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IANGLU,IBUGG3,IBUGCO,IBUGEV,IBUGQ 9014 FORMAT('IANGLU,IBUGG3,IBUGCO,IBUGEV,IBUGQ = ', 1A4,2X,A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IFOUND,IERROR 9015 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DP3DPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IANGLU,MAXNPP, 1IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,IFOUND,IERROR) C C PURPOSE--FORM A VARIETY OF 3-DIMENSIONAL PLOTS-- C 1) A Y VERSUS X1 AND X2 PLOT, C 2) A MULTI-TRACE (OR MULLTI-SURFACE) PLOT C 3) A 3-DIMENSIONAL FUNCTION PLOT. 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-921-3651 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--JANAURY 1981. C UPDATED --FEBRUARY 1981. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IANGLU CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ITYPEH CHARACTER*4 IW2HOL CHARACTER*4 IW22HO CHARACTER*4 IPARN CHARACTER*4 IPARN2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C C ***** THE FOLLOWING 4 DIMENSIONS RAISED FROM 150 TO 225 AUGUST 1983 ***** C ***** THE FOLLOWING 4 DIMENSIONS RAISED FROM 225 TO 1000 AUGUST 1986 ***** CCCCC DIMENSION ITYPEH(225) CCCCC DIMENSION IW2HOL(225) CCCCC DIMENSION IW22HO(225) CCCCC DIMENSION W2HOLD(225) DIMENSION ITYPEH(1000) DIMENSION IW2HOL(1000) DIMENSION IW22HO(1000) DIMENSION W2HOLD(1000) C DIMENSION PARAM(100) DIMENSION IPARN(100) DIMENSION IPARN2(100) C DIMENSION IVSLOC(100) DIMENSION IEQLOC(100) DIMENSION IFOLOC(100) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.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 IFOUND='NO' IERROR='NO' C ISUBN1='DP3D' ISUBN2='PL ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C C ***** THE FOLLOWING 6 LINES INSERTED AUGUST 1983 ***** DO40I=1,225 ITYPEH(I)=' ' IW2HOL(I)=' ' IW22HO(I)=' ' W2HOLD(I)=0.0 40 CONTINUE C C *************************** C ** TREAT THE PLOT CASE ** C *************************** C IF(IBUGG2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DP3DPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPLOTV,NPLOTP,NS 52 FORMAT('NPLOTV,NPLOTP,NS = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IANGLU,IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ 54 FORMAT('IANGLU,IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ = ', 1A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IFOUND,IERROR 55 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)MAXNPP 56 FORMAT('MAXNPP = ',I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICOM.EQ.'3DPL'.AND.ICOM2.EQ.'OT')GOTO110 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'3D'.AND.IHARG(1).EQ.'PLOT')GOTO120 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'3'.AND.IHARG(1).EQ.'D'.AND.IHARG(2).EQ.'PLOT') 1GOTO130 C IFOUND='NO' GOTO9000 C 110 CONTINUE GOTO180 C 120 CONTINUE ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 130 CONTINUE ILASTC=2 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 180 CONTINUE IFOUND='YES' GOTO190 C 190 CONTINUE C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=2 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ******************************************* C ** STEP 3-- ** C ** DETERMINE IF HAD OR HAVE THE 'AND' ** C ** CONTINUATION CASE. ** C ** IF THE PREVIOUS PLOT COMMAND LINE ** C ** HAD AN 'AND' CONTINUATION, ** C ** OR IF THE PRESENT PLOT COMMAND LINE ** C ** HAS AN 'AND' CONTINUATION, ** C ** THEN SET SOME FLAG VARIABLES. ** C ******************************************* C C ISTEPN='3' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IAND1.EQ.'NO')NPLOTV=0 IF(IAND1.EQ.'NO')NPLOTP=0 IAND2='NO' IF(IHARG(NUMARG).EQ.'AND')IAND2='YES' L=NPLOTP C C *************************************** C ** STEP 4-- ** C ** DETERMINE THE TYPE OF PLOT CASE ** C ** (FOR THIS COMMAND LINE ONLY)-- ** C ** 1) PLOT ... VERSUS ** C ** 2) PLOT ... FOR X = ** C ** 3) NEITHER OF THE ABOVE. ** C *************************************** C ISTEPN='4' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASPL='3DNO' C NUMEQ=0 NUMFO=0 NUMVS=0 NUMDV=0 DO811J=1,NUMARG J2=J IF(IHARG(J).EQ.'=')GOTO816 IF(IHARG(J).EQ.'VS')GOTO826 IF(IHARG(J).EQ.'VS.')GOTO826 IF(IHARG(J).EQ.'VERS'.AND.IHARG2(J).EQ.'US ')GOTO826 IF(IHARG(J).EQ.'FOR')GOTO836 GOTO811 C 816 CONTINUE NUMEQ=NUMEQ+1 IEQLOC(NUMEQ)=J2 GOTO811 C 826 CONTINUE NUMVS=NUMVS+1 IVSLOC(NUMVS)=J2 GOTO811 C 836 CONTINUE JP1=J+1 IF(JP1.GT.NUMARG)GOTO837 IF(IHARG(JP1).EQ.'I '.AND.IHARG2(JP1).EQ.' ')GOTO837 IF(IHARG(JP1).EQ.'ROW '.AND.IHARG2(JP1).EQ.' ')GOTO837 NUMDV=NUMDV+1 837 CONTINUE NUMFO=NUMFO+1 IFOLOC(NUMFO)=J2 GOTO811 C 811 CONTINUE C IF(NUMEQ.EQ.0)ICASPL='3DNO' IF(NUMEQ.EQ.1.AND.NUMFO.EQ.1.AND.NUMDV.LE.0)ICASPL='3DNO' IF(NUMEQ.EQ.1.AND.NUMFO.EQ.1.AND.NUMDV.GE.1)ICASPL='3DEF' IF(NUMEQ.GE.2)ICASPL='3DEF' IF(NUMVS.GE.1)ICASPL='3DVS' C 899 CONTINUE C C ****************************************** C ** STEP 5-- ** C ** BRANCH ACCORDING TO THE PLOT CASE. ** C ****************************************** C ISTEPN='5' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,911) 911 FORMAT('FROM THE MIDDLE OF DP3DPL--') IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(IBUGG2.EQ.'ON')WRITE(ICOUT,912)ICASPL 912 FORMAT('ICASPL = ',A4) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') C IFOUND='YES' C IF(ICASPL.EQ.'3DNO')GOTO1000 IF(ICASPL.EQ.'3DVS')GOTO2000 IF(ICASPL.EQ.'3DEF')GOTO3000 C WRITE(ICOUT,921) 921 FORMAT('***** ERROR IN DP3DPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,922) 922 FORMAT(' ICASPL NOT 3DNO, 3DVS, OR 3DEF') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,923)ICASPL,NUMEQ,NUMFO,NUMDV 923 FORMAT('ICASPL,NUMEQ,NUMFO,NUMDV = ',A4,3I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1000 CONTINUE CALL DP3DP1(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1MAXNPP, 1IBUGG3,IBUGQ,IFOUND,IERROR) GOTO9000 C 2000 CONTINUE CALL DP3DP2(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IVSLOC,NUMVS, 1MAXNPP, 1IBUGG3,IBUGQ,IFOUND,IERROR) GOTO9000 C 3000 CONTINUE CALL DP3DP3(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1PARAM,IPARN,IPARN2,NUMPAR,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD, 1IFOLOC, 1MAXNPP, 1IANGLU,IBUGG3,IBUGCO,IBUGEV,IBUGQ,IFOUND,IERROR) GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DP3DPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IANGLU,IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ 9014 FORMAT('IANGLU,IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ = ', 1A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)MAXNPP 9016 FORMAT('MAXNPP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020) 9020 FORMAT('I,Y(.),X(.),D(.),ISUB(.)--') CALL DPWRST('XXX','BUG ') DO9021I=1,NPLOTP WRITE(ICOUT,9022)I,Y(I),X(I),D(I),ISUB(I) 9022 FORMAT(I8,E15.7,E15.7,E15.7,I8) CALL DPWRST('XXX','BUG ') 9021 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DP3DTR(Z,X,Y,N,XEYE0,YEYE0,ZEYE0,XORIG,YORIG,ZORIG, 1I3DTRA, 1XEYE,YEYE,ZEYE, 1ZT,XT,IBUGPL,ISUBRO,IERROR) C C PURPOSE--CARRY OUT THE PERSPECTIVE TRANSFORMATION C WHICH CONVERTS POINTS IN 3-SPACE C TO POINTS ON THE PERSPECTIVE 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-921-3651 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--MARCH 1979. C UPDATED --APRIL 1979. C UPDATED --JANUARY 1981. C UPDATED --FEBRUARY 1981. C UPDATED --AUGUST 1981. C UPDATED --OCTOBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --JULY 1986. C UPDATED --SEPTEMBER 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 I3DTRA C CHARACTER*4 IBUGPL CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Z(*) DIMENSION X(*) DIMENSION Y(*) C DIMENSION ZT(*) DIMENSION XT(*) 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='DP3D' ISUBN2='TR ' C IERROR='NO' C DNXX=0.0 DNXY=0.0 DNXZ=0.0 DNYX=0.0 DNYY=0.0 DNYZ=0.0 DNZX=0.0 DNZY=0.0 DNZZ=0.0 DCXX=0.0 DCXY=0.0 DCXZ=0.0 DCYX=0.0 DCYY=0.0 DCYZ=0.0 DCZX=0.0 DCZY=0.0 DCZZ=0.0 DENOMX=0.0 DENOMY=0.0 DENOMZ=0.0 C IF(IBUGPL.EQ.'OFF'.AND.ISUBRO.NE.'3DTR')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DP3DTR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGPL,ISUBRO,IERROR 52 FORMAT('IBUGPL,ISUBRO,IERROR = ',3A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)I3DTRA 53 FORMAT('I3DTRA = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)N 61 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)XEYE0,YEYE0,ZEYE0 62 FORMAT('XEYE0, YEYE0, ZEYE0 = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)XORIG,YORIG,ZORIG 63 FORMAT('XORIG, YORIG, ZORIG = ',3E15.7) CALL DPWRST('XXX','BUG ') DO65I=1,N WRITE(ICOUT,66)I,Z(I),X(I),Y(I) 66 FORMAT('I,Z(I),X(I),Y(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 65 CONTINUE 90 CONTINUE C C ******************************************** C ** STEP 11-- ** C ** COMPUTE THE MIN AND MAX OF THE DATA. ** C ******************************************** C ISTEPN='11' IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'3DTR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'3DTR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C XMIN=X(1) XMAX=X(1) YMIN=Y(1) YMAX=Y(1) ZMIN=Z(1) ZMAX=Z(1) C DO1100I=1,N IF(X(I).LT.XMIN)XMIN=X(I) IF(X(I).GT.XMAX)XMAX=X(I) IF(Y(I).LT.YMIN)YMIN=Y(I) IF(Y(I).GT.YMAX)YMAX=Y(I) IF(Z(I).LT.ZMIN)ZMIN=Z(I) IF(Z(I).GT.ZMAX)ZMAX=Z(I) 1100 CONTINUE XRANGE=XMAX-XMIN YRANGE=YMAX-YMIN ZRANGE=ZMAX-ZMIN C C **************************************** C ** STEP 12-- ** C ** IF (XEYE0,YEYE0,ZEYE0) IS UNDEFINED ** C ** (THAT IS, = CPU MINIMUM), ** C ** THEN COMPUTE DEFAULT VALUES. ** C **************************************** C ISTEPN='12' IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'3DTR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) XEYE=XEYE0 YEYE=YEYE0 ZEYE=ZEYE0 IF(XEYE0.LE.CPUMIN)XEYE=XMAX+3.0*XRANGE IF(YEYE0.LE.CPUMIN)YEYE=YMAX+3.0*YRANGE IF(ZEYE0.LE.CPUMIN)ZEYE=ZMAX+3.0*ZRANGE C C ******************************************* C ** STEP 13-- ** 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='13' IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'3DTR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C XM=(XMIN+XMAX)/2.0 YM=(YMIN+YMAX)/2.0 ZM=(ZMIN+ZMAX)/2.0 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.'3DTR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C FACTOR=1.25 C XORIG2=XORIG YORIG2=YORIG ZORIG2=ZORIG IF(XORIG.EQ.CPUMIN)XORIG2=XMIN IF(YORIG.EQ.CPUMIN)YORIG2=YMIN IF(ZORIG.EQ.CPUMIN)ZORIG2=ZMIN C NP1=N+1 X(NP1)=XORIG2 Y(NP1)=YORIG2 Z(NP1)=ZORIG2 C NP2=N+2 X(NP2)=XORIG2+FACTOR*XRANGE Y(NP2)=YORIG2 Z(NP2)=ZORIG2 C NP3=N+3 X(NP3)=XORIG2 Y(NP3)=YORIG2 Z(NP3)=ZORIG2 C NP4=N+4 X(NP4)=XORIG2 Y(NP4)=YORIG2+FACTOR*YRANGE Z(NP4)=ZORIG2 C NP5=N+5 X(NP5)=XORIG2 Y(NP5)=YORIG2 Z(NP5)=ZORIG2 C NP6=N+6 X(NP6)=XORIG2 Y(NP6)=YORIG2 Z(NP6)=ZORIG2+FACTOR*ZRANGE 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 CLOAD/FIGURE ** C ** AS BEING LARGE IN APPEARANCE, ** C ** AND A DISTANT POINT CLOUD ** 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.'3DTR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C THETA=3.1415926/12.0 ARG=(XEYE-XM)**2+(YEYE-YM)**2+(ZEYE-ZM)**2 DIST=0.0 IF(ARG.GT.0.0)DIST=SQRT(ARG) RADIUS=DIST*TAN(THETA) IF(IBUGPL.EQ.'OFF'.AND.ISUBRO.NE.'3DTR')GOTO1519 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1511) 1511 FORMAT('***** FROM THE MIDDLE OF DP3DTR--') 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 = XM PLANE. ** C *********************************************************** C ISTEPN='15.2' IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'3DTR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C XD=XM YD1=YM YD2=YM ZD1=ZM ZD2=ZM C C ***** 7 LINES OF CODE TO ADJUST FOR DIVISION BY 0 ADDED AUGUST 1983 ***** EPS=0.0000001 XDEL=XEYE-XM IF(XDEL.EQ.0.0)XDEL=EPS YDEL=YEYE-YM IF(YDEL.EQ.0.0)YDEL=EPS ZDEL=ZEYE-ZM 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=ZM+RADIUS/DENOM ZD2=ZM+RADIUS/(-DENOM) YD1=CPUMIN IF(YDEL.NE.0.0)YD1=YM-ZDEL*(ZD1-ZM)/YDEL YD2=CPUMAX IF(YDEL.NE.0.0)YD2=YM-ZDEL*(ZD2-ZM)/YDEL 1520 CONTINUE C NP7=N+7 X(NP7)=XM Y(NP7)=YD1 Z(NP7)=ZD1 C NP8=N+8 X(NP8)=XM Y(NP8)=YD2 Z(NP8)=ZD2 C IF(IBUGPL.EQ.'OFF'.AND.ISUBRO.NE.'3DTR')GOTO1529 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1521)XM,RADIUS 1521 FORMAT('XM,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)N,NP7,X(NP7),Y(NP7),Z(NP7) 1524 FORMAT('N,NP7,X(NP7),Y(NP7),Z(NP7) = ',2I8,3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1525)N,NP8,X(NP8),Y(NP8),Z(NP8) 1525 FORMAT('N,NP8,X(NP8),Y(NP8),Z(NP8) = ',2I8,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 = YM PLANE. ** C *********************************************************** C ISTEPN='15.3' IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'3DTR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C XD1=XM XD2=XM YD=YM ZD1=ZM ZD2=ZM 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=ZM+RADIUS/DENOM ZD2=ZM+RADIUS/(-DENOM) XD1=CPUMIN IF(XDEL.NE.0.0)XD1=XM-ZDEL*(ZD1-ZM)/XDEL XD2=CPUMAX IF(XDEL.NE.0.0)XD2=XM-ZDEL*(ZD2-ZM)/XDEL C 1530 CONTINUE NP9=N+9 X(NP9)=XD1 Y(NP9)=YM Z(NP9)=ZD1 C NP10=N+10 X(NP10)=XD2 Y(NP10)=YM Z(NP10)=ZD2 C IF(IBUGPL.EQ.'OFF'.AND.ISUBRO.NE.'3DTR')GOTO1539 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1531)YM,RADIUS 1531 FORMAT('YM,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)N,NP9,X(NP9),Y(NP9),Z(NP9) 1534 FORMAT('N,NP9,X(NP9),Y(NP9),Z(NP9) = ',2I8,3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1535)N,NP10,X(NP10),Y(NP10),Z(NP10) 1535 FORMAT('N,NP10,X(NP10),Y(NP10),Z(NP10) = ',2I8,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 = ZM PLANE. ** C *********************************************************** C ISTEPN='15.4' IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'3DTR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C XD1=XM XD2=XM YD1=YM YD2=YM ZD=ZM 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=XM+RADIUS/DENOM XD2=XM+RADIUS/(-DENOM) YD1=CPUMIN IF(YDEL.NE.0.0)YD1=YM-XDEL*(XD1-XM)/YDEL YD2=CPUMAX IF(YDEL.NE.0.0)YD2=YM-XDEL*(XD2-XM)/YDEL C 1540 CONTINUE NP11=N+11 X(NP11)=XD1 Y(NP11)=YD1 Z(NP11)=ZM C NP12=N+12 X(NP12)=XD2 Y(NP12)=YD2 Z(NP12)=ZM C IF(IBUGPL.EQ.'OFF'.AND.ISUBRO.NE.'3DTR')GOTO1549 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1541)ZM,RADIUS 1541 FORMAT('ZM,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)N,NP11,X(NP11),Y(NP11),Z(NP11) 1544 FORMAT('N,NP11,X(NP11),Y(NP11),Z(NP11) = ',2I8,3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1545)N,NP12,X(NP12),Y(NP12),Z(NP12) 1545 FORMAT('N,NP12,X(NP12),Y(NP12),Z(NP12) = ',2I8,3E15.7) CALL DPWRST('XXX','BUG ') 1549 CONTINUE C C ********************************************************* C ** STEP 20-- 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 ** (XEYE-XM)(X-XM) + (YEYE-YM)(Y-YM) + (ZEYE-ZM)(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 (XD,YD,ZD) ** C ** TO OUR EYE (XEYE,YEYE,ZEYE) ARE C ** (X-XD)/(XEYE-XD) = (Y-YD)/(YEYE-YD) = (Z-ZD)/(ZEYE-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 ** STEP 21-- 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 (XEYE,YEYE,ZEY C ** AND WILL THEREFORE HAVE DIRECTIONS NUMBERS XEYE, YEYE, AND Z 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 (XEYE,YEYE,ZEYE) 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 = -XEYE/YEYE 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 XEYE, YEYE, AND ZEYE) 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 = YEYE/XEYE C ** F = (-XEYE*XEYE - YEYE*YEYE) / (XEYE*ZEYE) C ** C ** IN SUMMARY, THE DIRECTION NUMBERS FOR THE 3 NEW AXES C ** MAY BE WRITTEN AS C ** NEW X AXIS: YEYE -XEYE 0 C ** NEW Y AXIS: XEYE YEYE ZEYE C ** NEW Z AXIS: -XEYE*ZEYE -YEYE*ZEYE XEYE*XEYE+YEYE*YEY 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 ** DCXX DCXY DCXZ C ** DCYX DCYY DCYZ C ** DCZX DCZY DCZZ 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 + DCXX(X-XM) + DCXY(Y-YM) + DCXZ(Z-ZM) C ** YT = YM + DCYX(X-XM) + DCYY(Y-YM) + DCYZ(Z-ZM) C ** ZT = ZM + DCZX(X-XM) + DCZY(Y-YM) + DCZZ(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 ** (XEYE-XM)(X-XM) + (YEYE-YM)(Y-YM) + (ZEYE-ZM)(Z-ZM) = 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='21' IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'3DTR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DNXX=YEYE DNXY=-XEYE DNXZ=0.0 DNYX=XEYE DNYY=YEYE DNYZ=ZEYE DNZX=-XEYE*ZEYE DNZY=-YEYE*ZEYE DNZZ=XEYE*XEYE+YEYE*YEYE C DENOMX=SQRT(DNXX**2+DNXY**2+DNXZ**2) DENOMY=SQRT(DNYX**2+DNYY**2+DNYZ**2) DENOMZ=SQRT(DNZX**2+DNZY**2+DNZZ**2) C C ***** 15 LINES OF CODE TO CHECK FOR DIVISION BY 0 ADDED AUGUST 1983 ***** DCXX=CPUMAX DCXY=CPUMAX DCXZ=CPUMAX IF(DENOMX.EQ.0.0)GOTO2121 DCXX=DNXX/DENOMX DCXY=DNXY/DENOMX DCXZ=DNXZ/DENOMX 2121 CONTINUE C DCYX=CPUMAX DCYY=CPUMAX DCYZ=CPUMAX IF(DENOMY.EQ.0.0)GOTO2122 DCYX=DNYX/DENOMY DCYY=DNYY/DENOMY DCYZ=DNYZ/DENOMY 2122 CONTINUE C DCZX=CPUMAX DCZY=CPUMAX DCZZ=CPUMAX IF(DENOMZ.EQ.0.0)GOTO2123 DCZX=DNZX/DENOMZ DCZY=DNZY/DENOMZ DCZZ=DNZZ/DENOMZ 2123 CONTINUE C C ************************************************** C ** STEP 22-- ** C ** BRANCH TO THE APPROPRIATE ** C ** TRANSFORMATION ** C ************************************************** C ISTEPN='22' IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'3DTR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(I3DTRA.EQ.'ORTH')GOTO2300 GOTO2400 C C ************************************************** C ** STEP 23-- ** C ** TREAT THE ORTHOGRAPHIC TRANSFORMATION CASE ** C ************************************************** C 2300 CONTINUE C ISTEPN='23' IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'3DTR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C THE FOLLOWING IS INCORRECT (XM FOR X(I) ETC.) DO2310I=1,NP12 C C ***** 5 LINES OF CODE TO ADJUST FOR DIVISION BY 0 ADDED AUGUST 1983 ***** EPS=0.0000001 A11=XDEL A12=YDEL A13=ZDEL A23=YEYE-YM IF(A23.EQ.0.0)A21=EPS A23=-(XEYE-XM) IF(A23.EQ.0.0)A22=EPS A23=0.0 A31=0.0 A32=ZEYE-ZM IF(A32.EQ.0.0)A32=EPS A33=-(YEYE-YM) IF(A33.EQ.0.0)A33=EPS C R1=XDEL*XM+YDEL*YM+ZDEL*ZM R2=(YEYE-YM)*XM-(XEYE-XM)*YM R3=(ZEYE-ZM)*YM-(YEYE-YM)*ZM C P12=-A23/A11 P13=-A32/(P12*A12+A23) C ZPI=(P13*(P12*R1+R2)+R3)/ 1(P13*P12*A13+A33) YPI=(R3-A33*ZPI)/A32 XPI=(R2-A23*YPI)/A21 IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'3DTR') 1WRITE(ICOUT,2311)I,XPI,YPI,ZPI 2311 FORMAT('I,XPI,YPI,ZPI = ',I8,3E15.7) IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'3DTR') 1CALL DPWRST('XXX','BUG ') C DELX=XPI-XM DELY=YPI-YM DELZ=ZPI-ZM XT(I)=XM+DCXX*DELX+DCXY*DELY+DCXZ*DELZ CCCCC YT(I)=YM+DCYX*DELX+DCYY*DELY+DCYZ*DELZ ZT(I)=XM+DCZX*DELX+DCZY*DELY+DCZZ*DELZ C 2310 CONTINUE C C ************************************************** C ** STEP 22-- ** C ** TREAT THE PERSPECTIVE TRANSFORMATION CASE ** C ************************************************** C 2400 CONTINUE C ISTEPN='24' IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'3DTR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO2410I=1,NP12 C ISTEPN='1' IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'3DTR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ***** 5 LINES OF CODE TO ADJUST FOR DIVISION BY 0 ADDED AUGUST 1983 ***** EPS=0.0000001 A11=XDEL A12=YDEL A13=ZDEL A21=YEYE-Y(I) IF(A21.EQ.0.0)A21=EPS A22=-(XEYE-X(I)) IF(A22.EQ.0.0)A22=EPS A23=0.0 A31=0.0 A32=ZEYE-Z(I) IF(A32.EQ.0.0)A32=EPS A33=-(YEYE-Y(I)) IF(A33.EQ.0.0)A33=EPS C R1=XDEL*XM+YDEL*YM+ZDEL*ZM R2=(YEYE-Y(I))*X(I)-(XEYE-X(I))*Y(I) R3=(ZEYE-Z(I))*Y(I)-(YEYE-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(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'3DTR') 1WRITE(ICOUT,2411)I,XPI,YPI,ZPI 2411 FORMAT('I,XPI,YPI,ZPI = ',I8,3E15.7) IF(IBUGPL.EQ.'ON'.OR.ISUBRO.EQ.'3DTR') 1CALL DPWRST('XXX','BUG ') C C DELX=XPI-XM DELY=YPI-YM DELZ=ZPI-ZM XT(I)=XM+DCXX*DELX+DCXY*DELY+DCXZ*DELZ CCCCC YT(I)=YM+DCYX*DELX+DCYY*DELY+DCYZ*DELZ ZT(I)=XM+DCZX*DELX+DCZY*DELY+DCZZ*DELZ C 2410 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C IF(IBUGPL.EQ.'OFF'.AND.ISUBRO.NE.'3DTR')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DP3DTR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGPL,ISUBRO,IERROR 9012 FORMAT('IBUGPL.ISUBRO,IERROR = ',3A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)XEYE0,YEYE0,ZEYE0 9022 FORMAT('XEYE0, YEYE0, ZEYE0 = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9023)XEYE,YEYE,ZEYE 9023 FORMAT('XEYE, YEYE, ZEYE = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9024)XORIG,YORIG,ZORIG 9024 FORMAT('XORIG, YORIG, ZORIG = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9025)XORIG2,YORIG2,ZORIG2 9025 FORMAT('XORIG2, YORIG2, ZORIG2 = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9026)XRANGE,YRANGE,ZRANGE 9026 FORMAT('XRANGE, YRANGE, ZRANGE = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9027)XM,YM,ZM 9027 FORMAT('XM, YM, ZM = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9028)N,NP12 9028 FORMAT('N,NP12 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9029) 9029 FORMAT('I,X(I),Y(I),Z(I),XT(I),ZT(I)') CALL DPWRST('XXX','BUG ') DO9031I=1,NP12 WRITE(ICOUT,9032)I,X(I),Y(I),Z(I), 1XT(I),ZT(I) 9032 FORMAT(I4,7E11.4) CALL DPWRST('XXX','BUG ') 9031 CONTINUE WRITE(ICOUT,9041) 9041 FORMAT('DNXX,DNXY,DNXZ,DNYX,DNYY,DNYZ,DNZX,DNZY,DNZZ = ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9042)DNXX,DNXY,DNXZ,DNYX,DNYY,DNYZ,DNZX,DNZY,DNZZ 9042 FORMAT(9E13.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9043)DENOMX,DENOMY,DENOMZ 9043 FORMAT('DENOMX,DENOMY,DENOMZ = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9045) 9045 FORMAT('DCXX,DCXY,DCXZ,DCYX,DCYY,DCYZ,DCZX,DCZY,DCZZ = ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9046)DCXX,DCXY,DCXZ,DCYX,DCYY,DCYZ,DCZX,DCZY,DCZZ 9046 FORMAT(9E13.5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9051)XMIN,XMAX 9051 FORMAT('XMIN,XMAX = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9052)YMIN,YMAX 9052 FORMAT('YMIN,YMAX = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9053)ZMIN,ZMAX 9053 FORMAT('ZMIN,ZMAX = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9054)I3DTRA 9054 FORMAT('I3DTRA = ',A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DP3MSM(X,N,XS,ICHANG,IBUGG3,IERROR) C C PURPOSE--THIS SUBROUTINE TAKES THE DATA IN THE VECTOR X, C APPLIES A 3-TERM MEDIAN SMOOTH, AND PUTS THE C RESULTS IN A VECTOR XS. C NOTE--THE VECTOR X REMAINS UNCHANGED. C OUTPUT ARGUMENTS--XS = THE SINGLE PRECISION VECTOR C CONTAINING SMOOTHED VALUES. C --ICHANG = THE CHARACTER VARIABLE C CONTAINING EITHER YES OR NO C DEPENDING ON WHETHER OR NOT THE C SMOOTHED DATA IS CHANGED OR NOT C FROM THE ORIGINAL DATA. C OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR C OF SMOOTHED VALUES. C ASSUMPTION--THE VECTOR X HAS AT LEAST 3 VALUES. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--MCNEIL, INTERACTIVE DATA ANALYSIS C 1977, PAGE 144 C (= SOURCE OF ALGORITHM). 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-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C VERSION NUMBER--83.6 C ORIGINAL VERSION--JULY 1983. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHANG C CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION XS(*) 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' C IF(IBUGG3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DP3MSM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGG3 52 FORMAT('IBUGG3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) 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 ** SMOOTH THE DATA ** C ** VIA 3-TERM MEDIANS ** C ************************** C ARG1=X(1) ARG2=X(2) ARG3=3*X(2)+2*X(3) CALL DPMED3(ARG1,ARG2,ARG3,XMED3,IBUGG3,IERROR) XS(1)=XMED3 C NM1=N-1 DO1100I=2,NM1 IM1=I-1 IP1=I+1 ARG1=X(IM1) ARG2=X(I) ARG3=X(IP1) CALL DPMED3(ARG1,ARG2,ARG3,XMED3,IBUGG3,IERROR) XS(I)=XMED3 1100 CONTINUE C ARG1=X(N) ARG2=X(NM1) NM2=N-2 ARG3=3*X(NM1)+2*X(NM2) CALL DPMED3(ARG1,ARG2,ARG3,XMED3,IBUGG3,IERROR) XS(N)=XMED3 C ICHANG='NO' DO1200I=1,N IF(XS(I).NE.X(I))GOTO1210 1200 CONTINUE GOTO1290 1210 CONTINUE ICHANG='YES' 1290 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DP3MSM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGG3 9012 FORMAT('IBUGG3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICHANG 9013 FORMAT('ICHANG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)N 9014 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N WRITE(ICOUT,9016)I,X(I) 9016 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DP3RSM(X,XJUNK,N,XS,ICHANG,IBUGG3,IERROR) C C PURPOSE--THIS SUBROUTINE TAKES THE DATA IN THE VECTOR X, C AND REPEATEDLY APPLIES A 3-TERM MEDIAN SMOOTH C UNTIL NO CHANGE OCCURS AFTER THE SMOOTHING OPERATION. C OUTPUT ARGUMENTS--XS = THE SINGLE PRECISION VECTOR C CONTAINING SMOOTHED VALUES. C --ICHANG = THE CHARACTER VARIABLE C CONTAINING EITHER YES OR NO C DEPENDING ON WHETHER OR NOT THE C SMOOTHED DATA IS CHANGED OR NOT C FROM THE ORIGINAL DATA. C OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR C OF SMOOTHED VALUES. C NOTE--THE VECTOR X REMAINS UNCHANGED. C ASSUMPTION--THE VECTOR X HAS AT LEAST 3 VALUES. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--MCNEIL, INTERACTIVE DATA ANALYSIS C 1977, PAGE 145 C (= SOURCE OF ALGORITHM). 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-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C VERSION NUMBER--83.6 C ORIGINAL VERSION--JULY 1983. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHANG C CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION XJUNK(*) DIMENSION XS(*) 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' C IF(IBUGG3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DP3RSM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGG3 52 FORMAT('IBUGG3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) 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 ** SMOOTH THE DATA ** C ** VIA 3-TERM MEDIANS ** C ** REPEATED UNTIL CONVERGENCE ** C ********************************** C IF(N.GE.1)GOTO190 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN DP3RSM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' NUMBER OF OBSERVATIONS IS NON-POSITIVE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113)N 113 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 190 CONTINUE C IF(N.GE.3)GOTO290 DO210I=1,N XS(I)=X(I) 210 CONTINUE ICHANG='NO' GOTO9000 290 CONTINUE C C ************************************************ C ** STEP 1-- ** C ** SMOOTH THE RAW DATA WITH 3-TERM MEDIANS. ** C ** IF NO CHANGE, THEN EXIT. ** C ************************************************ C CALL DP3MSM(X,N,XS,ICHANG,IBUGG3,IERROR) IF(ICHANG.EQ.'NO')GOTO9000 C C ********************************************* C ** STEP 2-- ** C ** SINCE THERE WAS A CHANGE, THEN ** C ** REPEATEDLY SMOOTH THE SMOOTHED VALUES ** C ** UNTIL NO CHANGE. ** C ********************************************* C NUMIT=0 MAXIT=100 1100 CONTINUE NUMIT=NUMIT+1 CALL DP3MSM(XS,N,XJUNK,ICHANG,IBUGG3,IERROR) DO1200I=1,N XS(I)=XJUNK(I) 1200 CONTINUE IF(NUMIT.GT.MAXIT)GOTO1250 IF(ICHANG.EQ.'YES')GOTO1100 GOTO1290 1250 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1251) 1251 FORMAT('***** ERROR IN DP3RSM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1252) 1252 FORMAT(' NUMBER OF ITERATIONS HAS JUST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1253)MAXIT 1253 FORMAT(' EXCEEDED ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1290 CONTINUE C C ******************************************************** C ** STEP 3-- ** C ** MAKE A FINAL CHECK TO SEE IF THE SMOOTHED VALUES ** C ** HAVE CHANGED ANY FROM THE RAW DATA. ** C ******************************************************** C ICHANG='NO' DO1300I=1,N IF(XS(I).NE.X(I))GOTO1310 1300 CONTINUE GOTO1390 1310 CONTINUE ICHANG='YES' 1390 CONTINUE C C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DP3RSM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGG3 9012 FORMAT('IBUGG3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICHANG 9013 FORMAT('ICHANG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)N 9014 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N WRITE(ICOUT,9016)I,X(I),XJUNK(I),XS(I) 9016 FORMAT('I,X(I),XJUNK(I),XS(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DP3RSR(X,XJUNK,N,PRED2,RES2,IBUGG3,IERROR) C C PURPOSE--THIS SUBROUTINE TAKES THE DATA IN THE VECTOR X, C AND APPLIES A 3RSR SMOOTHING, THAT IS, C MEDIANS OF 3 (REPEATED UNTIL NO CHANGE) FOLLOWED BY C SPLITTING (REPEATED UNTIL NO CHANGE). C OUTPUT ARGUMENTS--PRED2 = THE SINGLE PRECISION VECTOR C CONTAINING SMOOTHED VALUES. C RES2 = THE SINGLE PRECISION VECTOR C CONTAINING RESIDUALS FROM THE SMOOTH. C OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR C OF SMOOTHED VALUES. C NOTE--THE VECTOR X REMAINS UNCHANGED. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--MCNEIL, INTERACTIVE DATA ANALYSIS C 1977, PAGE 146 AND 124 C (= SOURCE OF ALGORITHM). 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-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C VERSION NUMBER--83.6 C ORIGINAL VERSION--JULY 1983. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHANG C CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION XJUNK(*) DIMENSION PRED2(*) DIMENSION RES2(*) 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' C IF(IBUGG3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DP3RSR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGG3 52 FORMAT('IBUGG3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) 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 ** CARRY OUT A 3RSR SMOOTHING ** C ********************************** C IF(N.GE.1)GOTO190 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN DP3RSR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' NUMBER OF OBSERVATIONS IS NON-POSITIVE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113)N 113 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 190 CONTINUE C IF(N.GE.3)GOTO290 DO210I=1,N PRED2(I)=X(I) RES2(I)=0.0 210 CONTINUE ICHANG='NO' GOTO9000 290 CONTINUE C C ******************************************** C ** STEP 1-- ** C ** CARRY OUT A 3R SMOOTHING, THAT IS, ** C ** APPLY 3-TERM MEDIANS AND REPEAT THIS ** C ** UNTIL NO CHANGE ** C ******************************************** C CALL DP3RSM(X,RES2,N,PRED2,ICHANG,IBUGG3,IERROR) C C ************************************************************* C ** STEP 2-- ** C ** SET UP A LOOP. ** C ** INSIDE THE LOOP, CARRY OUT ** C ** 1) A SPLIT & SMOOTH ** C ** 2) A 3-TERM MEDIAN SMOOTH REPEATED UNTIL NO CHANGE ** C ** REPEAT THE LOOP UNTIL NO CHANGE ** C ************************************************************* C 1000 CONTINUE C C ******************************* C ** STEP 2.1-- ** C ** SPLIT & SMOOTH THE DATA ** C ******************************* C CALL DPSPSM(PRED2,N,RES2,ICHANG,IBUGG3,IERROR) C C **************************************************************** C ** STEP 2.2-- * C ** CARRY OUT A 3R SMOOTHING ON THE SMOOTHED VALUES, THAT IS, * C ** APPLY 3-TERM MEDIANS AND REPEAT UNTIL NO CHANGE * C **************************************************************** C CALL DP3RSM(RES2,XJUNK,N,PRED2,ICHANG,IBUGG3,IERROR) C C ******************************************************* C ** STEP 2.3-- ** C ** COPY RESIDUALS INTO RES2(.). ** C ** IF CHANGES HAD OCCURRED IN LAST 3R SMOOTH, ** C ** THEN REPEAT ENTIRE SPLIT/SMOOTH AND 3R PROCESS. ** C ******************************************************* C DO1100I=1,N RES2(I)=X(I)-PRED2(I) 1100 CONTINUE C IF(ICHANG.EQ.'YES')GOTO1000 C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DP3RSR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGG3 9012 FORMAT('IBUGG3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICHANG 9013 FORMAT('ICHANG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)N 9014 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N WRITE(ICOUT,9016)I,X(I),XJUNK(I),PRED2(I),RES2(I) 9016 FORMAT('I,X(I),XJUNK(I),PRED2(I),RES2(I) = ',I8,4E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DP4PLO(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IANGLU,MAXNPP, 1CLLIMI,CLWIDT, 1ICONT,NUMHPP,IMANUF, 1XMATN,YMATN,XMITN,YMITN, 1ISQUAR, 1IVGMSW,IHGMSW, 1IMPSW,IMPNR,IMPNC,IMPCO, 1PMXMIN,PMXMAX,PMYMIN,PMYMAX, 1IX3AUT,ITIAUT, CCCCC MARCH 1996. ADD FOLLOWING LINE 1IRHSTG,IHSTCW,IASHWT, CCCCC MARCH 2002. ADD FOLLOWING LINE 1I4PLMC,I4PLDI, 1ICAPSW, 1IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ, 1IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO, 1IFOUND,IERROR) C C PURPOSE--GENERATE THE FOLLOWING 4 PLOTS C (ALL ON THE SAME PAGE)-- C 1) A RUN SEQUENCE PLOT; C 2) A LAG PLOT; C 3) A HISTOGRAM; C 4) A NORMAL PROBABILITY PLOT; 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-921-3651 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/2 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--JANUARY 1989. C UPDATED --APRIL 1989. BY ALAN C UPDATED --NOVEMBER 1989. CHAR*4 FOR IBUGU.. (NELSON) C UPDATED --NOVEMBER 1989. DIM. FOR CLLIMI & CLWIDT C UPDATED --NOVEMBER 1989. ALLOW 4PLOT SYNONYM C UPDATED --AUGUST 1992. ARGUMENT LIST TO DPGRAP C UPDATED --DECEMBER 1993. ARGUMENT LIST TO DPPP C UPDATED --DECEMBER 1993. BUG WITH X3LAB C UPDATED --MARCH 1996. IRHSTG C UPDATED --AUGUST 1999. ARGUMENT LIST TO DPGRAP C UPDATED --MARCH 2002. SIZE BASED ON MULTIPLOT C CORNER COORDINATES C UPDATED --OCTOBER 2006. I4PLDI (GENERATE EXPO C PROB PLOT INSTEAD OF C NORMAL PROB PLOT) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICAPSW CHARACTER*4 ICASPL CHARACTER*4 I4PLDI CHARACTER*4 ICONT CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IANGLU CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 C CCCCC THE FOLLOWING 4 LINES WERE INSERTED NOVEMBER 1989 CCCCC (BUG UNCOVERED BY NELSON HSU) CHARACTER*4 IBUGUG CHARACTER*4 IBUGU2 CHARACTER*4 IBUGU3 CHARACTER*4 IBUGU4 C CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ISQUAR CHARACTER*4 IVGMSW CHARACTER*4 IHGMSW CHARACTER*4 IREPCH CHARACTER*4 IMPSW C CHARACTER*4 I4PLOT C CHARACTER*4 IERAS2 CHARACTER*4 ICOPS2 CHARACTER*4 ICHAP2 CHARACTER*4 ILINP2 C CHARACTER*4 IFEED9 C CHARACTER*4 IANSRS CHARACTER*4 IANSLP CHARACTER*4 IANSHI CHARACTER*4 IANSNP C CHARACTER*4 IMANUF C CHARACTER*4 IX3AUT CHARACTER*4 ITIAUT C CHARACTER*4 IRHSTG CHARACTER*4 IHSTCW CHARACTER*4 IASHWT CHARACTER*4 I4PLMC C CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C CCCCC THE FOLLOWING 2 LINES WERE INSERTED NOVEMBER 1989 CCCCC (BUG UNCOVERED BY NELSON HSU) DIMENSION CLLIMI(*) DIMENSION CLWIDT(*) C DIMENSION IANSRS(20) DIMENSION IANSLP(10) DIMENSION IANSHI(10) DIMENSION IANSNP(30) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPC.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.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-----DATA STATEMENTS------------------------------------------------- C DATA (IANSRS(I),I=1,18) 1/'R ','U ','N ',' ', 1 'S ','E ','Q ','U ','E ','N ','C ','E ', 1 ' ', 1 'P ','L ','O ','T ',' '/ DATA (IANSLP(I),I=1,9) 1/'L ','A ','G ',' ', 1 'P ','L ','O ','T ',' '/ DATA (IANSHI(I),I=1,10) 1/'H ','I ','S ','T ','O ', 1 'G ','R ','A ','M ',' '/ DATA (IANSNP(I),I=1,24) 1/'N ','O ','R ','M ','A ','L ',' ', CCCCC THE FOLLOWING LINE WAS FIXED DECEMBER 1993 CCCCC1 'P ','R ','O ','B ','A ','B ','A ','B ', 1 'P ','R ','O ','B ','A ','B ', 1 'I ','L ','I ','T ','Y ',' ', 1 'P ','L ','O ','T ',' '/ C C-----START POINT----------------------------------------------------- C IFOUND='YES' IERROR='NO' C ISUBN1='DP4P' ISUBN2='LO ' C I4PLOT='ON' NDONE=0 IVLOC=7 IF(IANS(7).EQ.' ')IVLOC=8 NCRS=18 NCLP=9 NCHI=10 CCCCC THE FOLLOWING CORRECTION WAS MADE JANUARY 1989 CCCCC NCNP=24 NCNP=25 C C ****************************************** C ** TREAT THE 4-PLOT ... ANALYSIS CASE ** C ****************************************** C IF(IBUGG2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DP4PLO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICASPL,IAND1,IAND2 52 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ 53 FORMAT('IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NUMARG 54 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMARG.LE.0)GOTO69 DO61I=1,NUMARG WRITE(ICOUT,62)I,IHARG(I),IARGT(I) 62 FORMAT('I,IHARG(I),IARGT(I) = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 61 CONTINUE 69 CONTINUE 90 CONTINUE C CCCCC THE FOLLOWING SECTION WAS INSERTED NOVEMBER 1989 C ************************************************** C ** STEP 10-- ** C ** EXTRACT THE COMMAND ** C ************************************************** C IF(ICOM.EQ.'4PLO')GOTO1010 GOTO1090 1010 CONTINUE ISHIFT=1 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1IBUGG3,IERROR) ICOM='4 ' ICOM2=' ' IHARG(1)='PLOT' IHARG2(1)=' ' IARG(1)=(-1) ARG(1)=(-1.0) IARGT(1)='WORD' 1090 CONTINUE C C ************************************************** C ** STEP 20-- ** C ** SAVE INITIAL SETTINGS ** C ************************************************** C ISTEPN='20' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'4PLO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C PWXMN2=PWXMIN PWXMX2=PWXMAX PWYMN2=PWYMIN PWYMX2=PWYMAX PMXMN2=PMXMIN PMXMX2=PMXMAX PMYMN2=PMYMIN PMYMX2=PMYMAX IF(I4PLMC.EQ.'OFF')THEN PMXMIN=0.0 PMXMAX=100.0 PMYMIN=0.0 PMYMAX=100.0 ENDIF IERAS2=IERASW ICOPS2=ICOPSW ICHAP2=ICHAPA(1) ILINP2=ILINPA(1) IFEED9=IFEEDB C C ************************************************** C ** STEP 21-- ** C ** GENERATE THE RUN SEQUENCE PLOT ** C ************************************************** C 2100 CONTINUE ISTEPN='21' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'4PLO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC MARCH 2002. USE MULTIPLOT CORNER COORDINATES CCCCC PWXMIN=0.0 CCCCC PWXMAX=50.0 CCCCC PWYMIN=50.0 CCCCC PWYMAX=100.0 PWXMIN=PMXMIN PWXMAX=PMXMIN + (PMXMAX-PMXMIN)/2.0 PWYMIN=PMYMAX - (PMYMAX-PMYMIN)/2.0 PWYMAX=PMYMAX ICOPSW='OFF' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1IBUGG3,IERROR) ICOM='PLOT' CALL DPPLOT(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IANGLU,MAXNPP, 1IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,IFOUND,IERROR) CCCCC THE FOLLOWING CORRECTION WAS MADE JANUARY 1989 CCCCC IF(IERROR.EQ.'YES')GOTO9000 JANUARY 1989 IF(IERROR.EQ.'YES')GOTO2800 C J=0 DO2111I=1,NCRS J=J+1 IF(IX3AUT.EQ.'ON')IX3LTE(J)=IANSRS(I) IF(ITIAUT.EQ.'ON')ITITTE(J)=IANSRS(I) 2111 CONTINUE GOTO2500 C C ************************************************** C ** STEP 22-- ** C ** GENERATE THE LAG PLOT ** C ************************************************** C 2200 CONTINUE ISTEPN='22' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'4PLO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC MARCH 2002. USE MULTIPLOT CORNER COORDINATES CCCCC PWXMIN=50.0 CCCCC PWXMAX=100.0 CCCCC PWYMIN=50.0 CCCCC PWYMAX=100.0 PWXMIN=PMXMIN + (PMXMAX-PMXMIN)/2.0 PWXMAX=PMXMAX PWYMIN=PMYMAX - (PMYMAX-PMYMIN)/2.0 PWYMAX=PMYMAX IERASW='OFF' ICOPSW='OFF' ICHAPA(1)='X ' ILINPA(1)=' ' IFEEDB='OFF' ISHIFT=1 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1IBUGG3,IERROR) ICOM='LAG ' IHARG(1)='PLOT' IHARG2(1)=' ' CALL DPLAG(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) CCCCC THE FOLLOWING CORRECTION WAS MADE JANUARY 1989 CCCCC IF(IERROR.EQ.'YES')GOTO9000 JANUARY 1989 IF(IERROR.EQ.'YES')GOTO2800 C J=0 DO2211I=1,NCLP J=J+1 IF(IX3AUT.EQ.'ON')IX3LTE(J)=IANSLP(I) IF(ITIAUT.EQ.'ON')ITITTE(J)=IANSLP(I) 2211 CONTINUE GOTO2500 C C ************************************************** C ** STEP 23-- ** C ** GENERATE THE HISTOGRAM ** C ************************************************** C 2300 CONTINUE ISTEPN='23' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'4PLO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC MARCH 2002. USE MULTIPLOT CORNER COORDINATES CCCCC PWXMIN=0.0 CCCCC PWXMAX=50.0 CCCCC PWYMIN=0.0 CCCCC PWYMAX=50.0 PWXMIN=PMXMIN PWXMAX=PMXMIN + (PMXMAX-PMXMIN)/2.0 PWYMIN=PMYMIN PWYMAX=PMYMIN + (PMYMAX-PMYMIN)/2.0 IERASW='OFF' ICOPSW='OFF' ICHAPA(1)=' ' ILINPA(1)='SOLI' IFEEDB='OFF' ICOM='HIST' CALL DPHIST(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1CLLIMI,CLWIDT,IASHWT, CCCCC MARCH 1996. ADD FOLLOWING LINE. 1IRHSTG,IHSTCW, 1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) CCCCC THE FOLLOWING CORRECTION WAS MADE JANUARY 1989 CCCCC IF(IERROR.EQ.'YES')GOTO9000 JANUARY 1989 IF(IERROR.EQ.'YES')GOTO2800 C J=0 DO2311I=1,NCHI J=J+1 IF(IX3AUT.EQ.'ON')IX3LTE(J)=IANSHI(I) IF(ITIAUT.EQ.'ON')ITITTE(J)=IANSHI(I) 2311 CONTINUE GOTO2500 C C ************************************************** C ** STEP 24-- ** C ** GENERATE THE NORMAL PROBABILITY PLOT ** C ************************************************** C 2400 CONTINUE ISTEPN='24' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'4PLO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC MARCH 2002. USE MULTIPLOT CORNER COORDINATES CCCCC PWXMIN=50.0 CCCCC PWXMAX=100.0 CCCCC PWYMIN=0.0 CCCCC PWYMAX=50.0 C CCCCC OCTOBER 2006. OPTIONALLY GENERATE EXPONENTIAL CCCCC PROBABILITY PLOT (E.G., WHEN CHECKING CCCCC FOR HOMOGENEOUS POISSON PROCESS). C PWXMIN=PMXMIN + (PMXMAX-PMXMIN)/2.0 PWXMAX=PMXMAX PWYMIN=PMYMIN PWYMAX=PMYMIN + (PMYMAX-PMYMIN)/2.0 IERASW='OFF' ICOPSW=ICOPS2 ICHAPA(1)=ICHAP2 ILINPA(1)=ILINP2 IFEEDB='OFF' ISHIFT=2 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1IBUGG3,IERROR) ICOM='NORM' IF(I4PLDI.EQ.'EXPO')ICOM='EXPO' IHARG(1)='PROB' IHARG(2)='PLOT' CALL DPPP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, CCCCC THE FOLLOWING LINE WAS CHANGED DECEMBER 1993 CCCCC1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) CCCCC THE FOLLOWING CORRECTION WAS MADE JANUARY 1989 CCCCC IF(IERROR.EQ.'YES')GOTO9000 JANUARY 1989 IF(IERROR.EQ.'YES')GOTO2800 C J=0 DO2411I=1,NCNP J=J+1 IF(IX3AUT.EQ.'ON')IX3LTE(J)=IANSNP(I) IF(ITIAUT.EQ.'ON')ITITTE(J)=IANSNP(I) 2411 CONTINUE GOTO2500 C C ************************************************** C ** STEP 25-- ** C ** PLOT THE CURRENT PLOT (OUT OF THE 4) ** C ************************************************** 2500 CONTINUE IF(IVLOC.GT.IWIDTH)GOTO2503 DO2502I=IVLOC,IWIDTH J=J+1 IF(IX3AUT.EQ.'ON')IX3LTE(J)=IANSLC(I) IF(ITIAUT.EQ.'ON')ITITTE(J)=IANSLC(I) 2502 CONTINUE 2503 CONTINUE IF(IX3AUT.EQ.'ON')NCX3LA=J IF(ITIAUT.EQ.'ON')NCTITL=J C ICONT=IDCONT(1) NUMHPP=IDNHPP(1) IF(IBUGG3.EQ.'ON')WRITE(ICOUT,2507)IMANUF,NUMDEV,IDMANU(1) 2507 FORMAT('IMANUF,NUMDEV,IDMANU(1) = ',A4,I8,2X,A4) IF(IBUGG3.EQ.'ON')CALL DPWRST('XXX','BUG ') CCCCC ADD FOLLOWING TO DPGRAP ARGUMENT LIST IMPARG=2 CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,NUMHPP, 1XMATN,YMATN,XMITN,YMITN, 1ISQUAR, 1IVGMSW,IHGMSW, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, 1YPLOT,XPLOT,X2PLOT,TAGPLO, 1IMPSW,IMPNR,IMPNC,IMPCO, 1IMPARG, 1PMXMIN,PMXMAX,PMYMIN,PMYMAX, 1MAXCOL, CCCCC AUGUST 1992. ADD FOLLOWING LINE 1DSIZE,DSYMB,DCOLOR,DFILL, 1ICAPSW, 1IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO, 1IERROR) CCCCC IF(IFOUND.EQ.'YES'.AND.IAND2.EQ.'NO')IAUTEX='OFF' IF(IERROR.EQ.'NO')IAND1=IAND2 IF(IERROR.EQ.'YES')GOTO9000 NDONE=NDONE+1 IF(NDONE.LE.1)GOTO2200 IF(NDONE.EQ.2)GOTO2300 IF(NDONE.EQ.3)GOTO2400 IF(NDONE.GE.4)GOTO2800 GOTO9000 C C ************************************************** C ** STEP 28-- ** C ** REINSTATE INITIAL SETTINGS ** C ************************************************** C 2800 CONTINUE ISTEPN='28' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'4PLO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) IF(IBUGG3.EQ.'ON')WRITE(ICOUT,2807)IMANUF,NUMDEV,IDMANU(1) 2807 FORMAT('IMANUF,NUMDEV,IDMANU(1) = ',A4,I8,2X,A4) IF(IBUGG3.EQ.'ON')CALL DPWRST('XXX','BUG ') PWXMIN=PWXMN2 PWXMAX=PWXMX2 PWYMIN=PWYMN2 PWYMAX=PWYMX2 PMXMIN=PMXMN2 PMXMAX=PMXMX2 PMYMIN=PMYMN2 PMYMAX=PMYMX2 IERASW=IERAS2 ICOPSW=ICOPS2 ICHAPA(1)=ICHAP2 ILINPA(1)=ILINP2 IFEEDB=IFEED9 ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1IBUGG3,IERROR) ICOM='4 ' IHARG(1)='PLOT' CCCCC THE FOLLOWING 1-LINE INSERTION WAS MADE JANUARY 1989 IF(IERROR.EQ.'YES')GOTO9000 GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DP4PLO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NUMARG 9014 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMARG.LE.0)GOTO9029 DO9021I=1,NUMARG WRITE(ICOUT,9022)I,IHARG(I),IARGT(I) 9022 FORMAT('I,IHARG(I),IARGT(I) = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9021 CONTINUE 9029 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DP6PLO(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IANGLU,MAXNPP, 1CLLIMI,CLWIDT, 1ICONT,NUMHPP,IMANUF, 1XMATN,YMATN,XMITN,YMITN, 1ISQUAR, 1IVGMSW,IHGMSW, 1IMPSW,IMPNR,IMPNC,IMPCO, 1PMXMIN,PMXMAX,PMYMIN,PMYMAX, 1IX3AUT,ITIAUT, CCCCC MARCH 1996. ADD FOLLOWING LINE 1IRHSTG,IHSTCW,IASHWT, CCCCC MARCH 2002. ADD FOLLOWING LINE 1I6PLMC, 1ICAPSW, 1IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ, 1IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO, 1IFOUND,IERROR) C C PURPOSE--GENERATE THE FOLLOWING 6 (POST-FIT VALIDATION) C PLOTS (ALL ON THE SAME PAGE)-- C 1) Y & PREDICTED VERSUS X C 2) RESIDUALS VERSUS X C 3) RESIDUALS VERSUS PREDICTED C 4) LAG PLOT OF RESIDUALS C 5) HISTOGRAM OF RESIDUALS C 6) NORMAL PROBABILITY PLOT OF RESIDUALS 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-921-3651 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/12 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--DECEMBER 1993. C UPDATED --MARCH 1996. IRHSTG TO DPHIST C UPDATED --AUGUST 1999. DPGRAP ARGUMENT LIST C UPDATED --MARCH 2002. SUPPORT FOR MULTIPLOT CORNER C COORDINATES (I6PLMC SWITCH) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICAPSW CHARACTER*4 ICASPL CHARACTER*4 ICONT CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IANGLU CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 C CHARACTER*4 IBUGUG CHARACTER*4 IBUGU2 CHARACTER*4 IBUGU3 CHARACTER*4 IBUGU4 C CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ISQUAR CHARACTER*4 IVGMSW CHARACTER*4 IHGMSW CHARACTER*4 IREPCH CHARACTER*4 IMPSW C CHARACTER*4 I6PLOT C CHARACTER*4 IERAS2 CHARACTER*4 ICOPS2 CHARACTER*4 ICHAP1 CHARACTER*4 ICHAP2 CHARACTER*4 ILINP1 CHARACTER*4 ILINP2 C CHARACTER*4 IFEED9 C CHARACTER*4 IANSYX CHARACTER*4 IANSRX CHARACTER*4 IANSRP CHARACTER*4 IANSLP CHARACTER*4 IANSHI CHARACTER*4 IANSNP C CHARACTER*4 ICOMSV CHARACTER*4 ICO2SV CHARACTER*4 IHARSV CHARACTER*4 IHA2SV CHARACTER*4 IARTSV C CHARACTER*4 IMANUF C CHARACTER*4 IX3AUT CHARACTER*4 ITIAUT C CHARACTER*4 IHVERT CHARACTER*4 IHVER2 CHARACTER*4 IHHORI CHARACTER*4 IHHOR2 C CHARACTER*4 IH4 CHARACTER*1 IH1 CCCCC MARCH 1996. ADD FOLLOWING LINE CHARACTER*4 IRHSTG CHARACTER*4 IHSTCW CHARACTER*4 IASHWT CCCCC MARCH 2002. ADD FOLLOWING LINE CHARACTER*4 I6PLMC C CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION CLLIMI(*) DIMENSION CLWIDT(*) C DIMENSION IANSYX(30) DIMENSION IANSRX(30) DIMENSION IANSRP(30) DIMENSION IANSLP(30) DIMENSION IANSHI(30) DIMENSION IANSNP(30) C DIMENSION IHARSV(100) DIMENSION IHA2SV(100) DIMENSION IARGSV(100) DIMENSION ARGSV(100) DIMENSION IARTSV(100) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPC.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.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-----DATA STATEMENTS------------------------------------------------- C DATA (IANSYX(I),I=1,5) 1/'P ','L ','O ','T ',' '/ DATA (IANSRX(I),I=1,9) 1/'P ','L ','O ','T ',' ', 1 'R ','E ','S ',' '/ DATA (IANSRP(I),I=1,14) 1/'P ','L ','O ','T ',' ', 1 'R ','E ','S ',' ', 1 'P ','R ','E ','D ',' '/ DATA (IANSLP(I),I=1,13) 1/'L ','A ','G ',' ', 1 'P ','L ','O ','T ',' ', 1 'R ','E ','S ',' '/ DATA (IANSHI(I),I=1,14) 1/'H ','I ','S ','T ','O ', 1 'G ','R ','A ','M ',' ', 1 'R ','E ','S ',' '/ DATA (IANSNP(I),I=1,28) 1/'N ','O ','R ','M ','A ','L ',' ', 1 'P ','R ','O ','B ','A ','B ', 1 'I ','L ','I ','T ','Y ',' ', 1 'P ','L ','O ','T ',' ', 1 'R ','E ','S ',' '/ C C-----START POINT----------------------------------------------------- C IFOUND='YES' IERROR='NO' C ISUBN1='DP6P' ISUBN2='LO ' C I6PLOT='ON' NDONE=0 ILOCV=7 IF(IANS(7).EQ.' ')ILOCV=8 NCYX=5 NCRX=9 NCRP=14 NCLP=13 NCHI=14 NCNP=28 C C ************************************************* C ** TREAT THE 6-PLOT Y X ANALYSIS CASE ** C ************************************************* C IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'6PLO')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DP6PLO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICASPL,IAND1,IAND2 52 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ 53 FORMAT('IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NUMARG 54 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMARG.LE.0)GOTO69 DO61I=1,NUMARG WRITE(ICOUT,62)I,IHARG(I),IARGT(I) 62 FORMAT('I,IHARG(I),IARGT(I) = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 61 CONTINUE 69 CONTINUE 90 CONTINUE C C ************************************************** C ** STEP 10-- ** C ** EXTRACT THE COMMAND ** C ************************************************** C IF(ICOM.EQ.'6PLO')THEN ISHIFT=1 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG3,IERROR) ICOM='6 ' ICOM2=' ' IHARG(1)='PLOT' IHARG2(1)=' ' IARG(1)=(-1) ARG(1)=(-1.0) IARGT(1)='WORD' ENDIF C C ************************************************** C ** STEP 20-- ** C ** SAVE INITIAL SETTINGS ** C ************************************************** C ISTEPN='20' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'6PLO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C PWXMN2=PWXMIN PWXMX2=PWXMAX PWYMN2=PWYMIN PWYMX2=PWYMAX PMXMN2=PMXMIN PMXMX2=PMXMAX PMYMN2=PMYMIN PMYMX2=PMYMAX IF(I6PLMC.EQ.'OFF')THEN PMXMIN=10.0 PMXMAX=90.0 PMYMIN=20.0 PMYMAX=90.0 ENDIF PMXINC=(PMXMAX-PMXMIN)/3.0 PMYINC=(PMYMAX-PMYMIN)/2.0 IERAS2=IERASW ICOPS2=ICOPSW ICHAP1=ICHAPA(1) ICHAP2=ICHAPA(2) ILINP1=ILINPA(1) ILINP2=ILINPA(2) IFEED9=IFEEDB C IHVERT=IHARG(2) IHVER2=IHARG2(2) IHHORI=IHARG(3) IHHOR2=IHARG2(3) C ICOMSV=ICOM ICO2SV=ICOM2 NUMASV=NUMARG DO1100I=1,NUMARG IHARSV(I)=IHARG(I) IHA2SV(I)=IHARG2(I) IARGSV(I)=IARG(I) ARGSV(I)=ARG(I) IARTSV(I)=IARGT(I) 1100 CONTINUE C C ************************************** C ** STEP XX-- ** C ** LOCATE SUBSET/EXCEPT/FOR ** C ** (STORE IT IN ILOCSF) ** C ************************************** C ILOCSF=IWIDTH+1 IMAX=IWIDTH-6 IF(IMAX.GE.1)THEN DO1200I=1,IMAX IP1=I+1 IP2=I+2 IP3=I+3 IP4=I+4 IP5=I+5 IP6=I+6 ILOCSF=I IF(IANSLC(I).EQ.'S'.AND.IANSLC(IP1).EQ.'U'.AND. 1 IANSLC(IP2).EQ.'B'.AND.IANSLC(IP3).EQ.'S'.AND. 1 IANSLC(IP4).EQ.'E'.AND.IANSLC(IP5).EQ.'T'.AND. 1 IANSLC(IP6).EQ.' ')GOTO1290 IF(IANSLC(I).EQ.'E'.AND.IANSLC(IP1).EQ.'X'.AND. 1 IANSLC(IP2).EQ.'C'.AND.IANSLC(IP3).EQ.'E'.AND. 1 IANSLC(IP4).EQ.'P'.AND.IANSLC(IP5).EQ.'T'.AND. 1 IANSLC(IP6).EQ.' ')GOTO1290 IF(IANSLC(I).EQ.'F'.AND.IANSLC(IP1).EQ.'O'.AND. 1 IANSLC(IP2).EQ.'R'.AND.IANSLC(IP3).EQ.' ')GOTO1290 IF(IANSLC(I).EQ.'s'.AND.IANSLC(IP1).EQ.'u'.AND. 1 IANSLC(IP2).EQ.'b'.AND.IANSLC(IP3).EQ.'s'.AND. 1 IANSLC(IP4).EQ.'e'.AND.IANSLC(IP5).EQ.'t'.AND. 1 IANSLC(IP6).EQ.' ')GOTO1290 IF(IANSLC(I).EQ.'e'.AND.IANSLC(IP1).EQ.'x'.AND. 1 IANSLC(IP2).EQ.'c'.AND.IANSLC(IP3).EQ.'e'.AND. 1 IANSLC(IP4).EQ.'p'.AND.IANSLC(IP5).EQ.'t'.AND. 1 IANSLC(IP6).EQ.' ')GOTO1290 IF(IANSLC(I).EQ.'f'.AND.IANSLC(IP1).EQ.'o'.AND. 1 IANSLC(IP2).EQ.'r'.AND.IANSLC(IP3).EQ.' ')GOTO1290 1200 CONTINUE ILOCSF=IWIDTH+1 ENDIF 1290 CONTINUE C C ************************************************** C ** STEP 21-- ** C ** GENERATE PLOT Y PRED VS X ** C ************************************************** C 2100 CONTINUE ISTEPN='21' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'6PLO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IFLAG=1 C CCCCC MARCH 2002. SUPPORT FOR MULUTPLOT CORNER COORDINATES CCCCC PWXMIN=10.0 CCCCC PWXMAX=36.666667 CCCCC PWYMIN=50.0 CCCCC PWYMAX=90.0 PWXMIN=PMXMIN PWXMAX=PMXMIN + PMXINC PWYMIN=PMYMIN + PMYINC PWYMAX=PMYMAX C ICOPSW='OFF' IFEEDB='OFF' ICHAPA(1)='X ' ICHAPA(2)=' ' ILINPA(1)=' ' ILINPA(2)='SOLI' C ISHIFT=1 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1IBUGG3,IERROR) ICOM='PLOT' ICOM2=' ' IHARG(1)=IHVERT IHARG2(1)=IHVER2 IHARG(2)='PRED' IHARG2(2)=' ' IHARG(3)='VS ' IHARG2(3)=' ' IHARG(4)=IHHORI IHARG2(4)=IHHOR2 CALL DPPLOT(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IANGLU,MAXNPP, 1IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,IFOUND,IERROR) IF(IERROR.EQ.'YES')GOTO8000 C IF(IX3AUT.EQ.'ON'.OR.ITIAUT.EQ.'ON')THEN J=NCYX DO2111I=1,4 IH4=' ' IH1=IHVERT(I:I) IH4(1:1)=IH1 IF(IH1.NE.' ')THEN J=J+1 IANSYX(J)=IH4 ENDIF 2111 CONTINUE DO2112I=1,4 IH4=' ' IH1=IHVER2(I:I) IH4(1:1)=IH1 IF(IH1.NE.' ')THEN J=J+1 IANSYX(J)=IH4 ENDIF 2112 CONTINUE J=J+1 IANSYX(J)=' ' J=J+1 IANSYX(J)='P' J=J+1 IANSYX(J)='R' J=J+1 IANSYX(J)='E' J=J+1 IANSYX(J)='D' J=J+1 IANSYX(J)=' ' J=J+1 IANSYX(J)='V' J=J+1 IANSYX(J)='S' J=J+1 IANSYX(J)=' ' DO2113I=1,4 IH4=' ' IH1=IHHORI(I:I) IH4(1:1)=IH1 IF(IH1.NE.' ')THEN J=J+1 IANSYX(J)=IH4 ENDIF 2113 CONTINUE DO2114I=1,4 IH4=' ' IH1=IHHOR2(I:I) IH4(1:1)=IH1 IF(IH1.NE.' ')THEN J=J+1 IANSYX(J)=IH4 ENDIF 2114 CONTINUE ENDIF JHOLD=J GOTO6000 C C ************************************************** C ** STEP 22-- ** C ** GENERATE PLOT RES X ** C ************************************************** C 2200 CONTINUE ISTEPN='22' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'6PLO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IFLAG=2 C CCCCC MARCH 2002. SUPPORT FOR MULUTPLOT CORNER COORDINATES CCCCC PWXMIN=36.666667 CCCCC PWXMAX=63.333333 CCCCC PWYMIN=50.0 CCCCC PWYMAX=90.0 PWXMIN=PMXMIN + PMXINC PWXMAX=PMXMIN + 2.0*PMXINC PWYMIN=PMYMIN + PMYINC PWYMAX=PMYMAX C IERASW='OFF' ICOPSW='OFF' IFEEDB='OFF' ICHAPA(1)=ICHAP1 ILINPA(1)=ILINP1 C ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1IBUGG3,IERROR) ICOM='PLOT' ICOM2=' ' IHARG(1)='RES ' IHARG2(1)=' ' IHARG(2)=IHHORI IHARG2(2)=IHHOR2 CALL DPPLOT(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IANGLU,MAXNPP, 1IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,IFOUND,IERROR) IF(IERROR.EQ.'YES')GOTO8000 C IF(IX3AUT.EQ.'ON'.OR.ITIAUT.EQ.'ON')THEN J=NCRX DO2211I=1,4 IH4=' ' IH1=IHHORI(I:I) IH4(1:1)=IH1 IH4(1:1)=IH1 IF(IH1.NE.' ')THEN J=J+1 IANSRX(J)=IH4 ENDIF 2211 CONTINUE DO2212I=1,4 IH4=' ' IH1=IHHOR2(I:I) IH4(1:1)=IH1 IF(IH1.NE.' ')THEN J=J+1 IANSRX(J)=IH4 ENDIF 2212 CONTINUE J=J+1 IANSRX(J)=' ' ENDIF JHOLD=J GOTO6000 C C ************************************************** C ** STEP 23-- ** C ** GENERATE PLOT RES PRED ** C ************************************************** C 2300 CONTINUE ISTEPN='23' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'6PLO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IFLAG=3 C CCCCC MARCH 2002. SUPPORT FOR MULUTPLOT CORNER COORDINATES CCCCC PWXMIN=63.333333 CCCCC PWXMAX=90.0 CCCCC PWYMIN=50.0 CCCCC PWYMAX=90.0 PWXMIN=PMXMIN + 2.0*PMXINC PWXMAX=PMXMAX PWYMIN=PMYMIN + PMYINC PWYMAX=PMYMAX C IERASW='OFF' ICOPSW='OFF' IFEEDB='OFF' ICHAP1=ICHAPA(1) ILINP1=ILINPA(1) C ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1IBUGG3,IERROR) ICOM='PLOT' ICOM2=' ' IHARG(1)='RES ' IHARG2(1)=' ' IHARG(2)='PRED' IHARG2(2)=' ' CALL DPPLOT(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IANGLU,MAXNPP, 1IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,IFOUND,IERROR) IF(IERROR.EQ.'YES')GOTO8000 C J=NCRP JHOLD=J GOTO6000 C C ************************************************** C ** STEP 24-- ** C ** GENERATE LAG PLOT RES ** C ************************************************** C 2400 CONTINUE ISTEPN='24' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'6PLO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IFLAG=4 C CCCCC MARCH 2002. SUPPORT FOR MULUTPLOT CORNER COORDINATES CCCCC PWXMIN=10.0 CCCCC PWXMAX=36.666667 CCCCC PWYMIN=10.0 CCCCC PWYMAX=50.0 PWXMIN=PMXMIN PWXMAX=PMXMIN + PMXINC PWYMIN=PMYMIN PWYMAX=PMYMIN + PMYINC C IERASW='OFF' ICOPSW='OFF' IFEEDB='OFF' ICHAPA(1)='X ' ILINPA(1)=' ' C ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1IBUGG3,IERROR) ICOM='LAG ' ICOM2=' ' IHARG(1)='PLOT' IHARG2(1)=' ' IHARG(2)='RES ' IHARG2(2)=' ' CALL DPLAG(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) IF(IERROR.EQ.'YES')GOTO8000 C J=NCLP JHOLD=J GOTO6000 C C ************************************************** C ** STEP 25-- ** C ** GENERATE HISTOGRAM RES ** C ************************************************** C 2500 CONTINUE ISTEPN='25' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'6PLO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IFLAG=5 C CCCCC MARCH 2002. SUPPORT FOR MULUTPLOT CORNER COORDINATES CCCCC PWXMIN=36.666667 CCCCC PWXMAX=63.333333 CCCCC PWYMIN=10.0 CCCCC PWYMAX=50.0 PWXMIN=PMXMIN + PMXINC PWXMAX=PMXMIN + 2.0*PMXINC PWYMIN=PMYMIN PWYMAX=PMYMIN + PMYINC C IERASW='OFF' ICOPSW='OFF' IFEEDB='OFF' ICHAPA(1)=' ' ILINPA(1)='SOLI' C ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1IBUGG3,IERROR) ICOM='HIST' ICOM2=' ' IHARG(1)='RES ' IHARG2(1)=' ' CALL DPHIST(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1CLLIMI,CLWIDT,IASHWT, CCCCC MARCH 1996. ADD FOLLOWING LINE 1IRHSTG,IHSTCW, 1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) IF(IERROR.EQ.'YES')GOTO8000 C J=NCHI JHOLD=J GOTO6000 C C ************************************************** C ** STEP 26-- ** C ** GENERATE NORMAL PROBABILITY PLOT RES ** C ************************************************** C 2600 CONTINUE ISTEPN='26' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'6PLO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IFLAG=6 C CCCCC MARCH 2002. SUPPORT FOR MULUTPLOT CORNER COORDINATES CCCCC PWXMIN=63.333333 CCCCC PWXMAX=90.0 CCCCC PWYMIN=10.0 CCCCC PWYMAX=50.0 PWXMIN=PMXMIN + 2.0*PMXINC PWXMAX=PMXMAX PWYMIN=PMYMIN PWYMAX=PMYMIN + PMYINC C IERASW='OFF' ICOPSW=ICOPS2 IFEEDB='OFF' ICHAPA(1)=ICHAP1 ILINPA(1)=ILINP1 C CCCCC ISHIFT=0 CCCCC CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, CCCCC1IBUGG3,IERROR) ICOM='NORM' ICOM2=' ' IHARG(1)='PROB' IHARG2(1)=' ' IHARG(2)='PLOT' IHARG2(2)=' ' IHARG(3)='RES ' IHARG2(3)=' ' CALL DPPP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IERROR.EQ.'YES')GOTO8000 C J=NCNP JHOLD=J GOTO6000 C C ************************************************** C ** STEP 60-- ** C ** PLOT THE CURRENT PLOT (OUT OF THE 6) ** C ************************************************** 6000 CONTINUE ISTEPN='60' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'6PLO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IX3AUT.EQ.'ON')THEN J=0 DO6011I=1,JHOLD J=J+1 IF(IFLAG.EQ.1)IX3LTE(J)=IANSYX(J) IF(IFLAG.EQ.2)IX3LTE(J)=IANSRX(J) IF(IFLAG.EQ.3)IX3LTE(J)=IANSRP(J) IF(IFLAG.EQ.4)IX3LTE(J)=IANSLP(J) IF(IFLAG.EQ.5)IX3LTE(J)=IANSHI(J) IF(IFLAG.EQ.6)IX3LTE(J)=IANSNP(J) 6011 CONTINUE IF(ILOCSF.LE.IWIDTH)THEN J=JHOLD DO6012I=ILOCSF,IWIDTH J=J+1 IX3LTE(J)=IANSLC(I) 6012 CONTINUE ENDIF NCX3LA=J ENDIF C IF(ITIAUT.EQ.'ON')THEN J=0 DO6021I=1,JHOLD J=J+1 IF(IFLAG.EQ.1)ITITTE(J)=IANSYX(J) IF(IFLAG.EQ.2)ITITTE(J)=IANSRX(J) IF(IFLAG.EQ.3)ITITTE(J)=IANSRP(J) IF(IFLAG.EQ.4)ITITTE(J)=IANSLP(J) IF(IFLAG.EQ.5)ITITTE(J)=IANSHI(J) IF(IFLAG.EQ.6)ITITTE(J)=IANSNP(J) 6021 CONTINUE IF(ILOCSF.LE.IWIDTH)THEN J=JHOLD DO6022I=ILOCSF,IWIDTH J=J+1 ITITTE(J)=IANSLC(I) 6022 CONTINUE ENDIF NCTITL=J ENDIF C ICONT=IDCONT(1) NUMHPP=IDNHPP(1) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'6PLO')THEN WRITE(ICOUT,6031)IMANUF,NUMDEV,IDMANU(1) 6031 FORMAT('IMANUF,NUMDEV,IDMANU(1) = ',A4,I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6032)NDONE 6032 FORMAT('NDONE = ',I8) CALL DPWRST('XXX','BUG ') ENDIF C CCCCC ADD FOLLOWING TO DPGRAP ARGUMENT LIST IMPARG=2 CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,NUMHPP, 1XMATN,YMATN,XMITN,YMITN, 1ISQUAR, 1IVGMSW,IHGMSW, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, 1YPLOT,XPLOT,X2PLOT,TAGPLO, 1IMPSW,IMPNR,IMPNC,IMPCO, 1IMPARG, 1PMXMIN,PMXMAX,PMYMIN,PMYMAX, 1MAXCOL, 1DSIZE,DSYMB,DCOLOR,DFILL, 1ICAPSW, 1IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO, 1IERROR) IF(IERROR.EQ.'NO')IAND1=IAND2 IF(IERROR.EQ.'YES')GOTO9000 C NDONE=NDONE+1 C ICOM=ICOMSV ICOM2=ICO2SV NUMARG=NUMASV DO6050I=1,NUMARG IHARG(I)=IHARSV(I) IHARG2(I)=IHA2SV(I) IARG(I)=IARGSV(I) ARG(I)=ARGSV(I) IARGT(I)=IARTSV(I) 6050 CONTINUE C IF(NDONE.LE.1)GOTO2200 IF(NDONE.EQ.2)GOTO2300 IF(NDONE.EQ.3)GOTO2400 IF(NDONE.EQ.4)GOTO2500 IF(NDONE.EQ.5)GOTO2600 IF(NDONE.GE.6)GOTO8000 C C ************************************************** C ** STEP 80-- ** C ** REINSTATE INITIAL SETTINGS ** C ************************************************** C 8000 CONTINUE ISTEPN='80' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'6PLO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'6PLO')THEN WRITE(ICOUT,8007)IMANUF,NUMDEV,IDMANU(1) 8007 FORMAT('IMANUF,NUMDEV,IDMANU(1) = ',A4,I8,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF C PWXMIN=PWXMN2 PWXMAX=PWXMX2 PWYMIN=PWYMN2 PWYMAX=PWYMX2 C IERASW=IERAS2 ICOPSW=ICOPS2 IFEEDB=IFEED9 ICHAPA(1)=ICHAP1 ICHAPA(2)=ICHAP2 ILINPA(1)=ILINP1 ILINPA(2)=ILINP2 C ICOM='6 ' ICOM2=' ' IHARG(1)='PLOT' IHARG2(1)=' ' IHARG(2)=IHVERT IHARG2(2)=IHVER2 IHARG(3)=IHHORI IHARG2(3)=IHHOR2 IF(IERROR.EQ.'YES')GOTO9000 GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'6PLO')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DP6PLO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NDONE 9014 FORMAT('NDONE = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IHVERT,IHVER2 9015 FORMAT('IHVERT,IHVER2 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)IHHORI,IHHOR2 9016 FORMAT('IHHORI,IHHOR2 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)NUMARG 9017 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)IBUGG2,ISUBRO,IERROR 9018 FORMAT('IBUGG2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') IF(NUMARG.LE.0)GOTO9029 DO9021I=1,NUMARG WRITE(ICOUT,9022)I,IHARG(I),IARGT(I) 9022 FORMAT('I,IHARG(I),IARGT(I) = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9021 CONTINUE 9029 CONTINUE 9090 CONTINUE C RETURN END