source: Sophya/trunk/SophyaExt/CodeMinuit/code/mncrck.F@ 3191

Last change on this file since 3191 was 2403, checked in by cmv, 22 years ago

Creation du module de code source de MINUIT (CERNLIB) extrait par CMV

cmv 11/06/2003
File size: 4.2 KB
Line 
1*
2* $Id: mncrck.F,v 1.1.1.1 2003-06-11 14:18:26 cmv Exp $
3*
4* $Log: not supported by cvs2svn $
5* Revision 1.1.1.1 1996/03/07 14:31:29 mclareni
6* Minuit
7*
8*
9#include "minuit/pilot.h"
10 SUBROUTINE MNCRCK(CRDBUF,MAXCWD,COMAND,LNC,
11 + MXP, PLIST, LLIST,IERR,ISYSWR)
12#include "minuit/d506dp.inc"
13CC
14CC Called from MNREAD.
15CC Cracks the free-format input, expecting zero or more
16CC alphanumeric fields (which it joins into COMAND(1:LNC))
17CC followed by one or more numeric fields separated by
18CC blanks and/or one comma. The numeric fields are put into
19CC the LLIST (but at most MXP) elements of PLIST.
20CC IERR = 0 if no errors,
21CC = 1 if error(s).
22CC Diagnostic messages are written to ISYSWR
23CC
24 PARAMETER (MAXELM=25, MXLNEL=19)
25 CHARACTER*(*) COMAND, CRDBUF
26 CHARACTER CNUMER*13, CELMNT(MAXELM)*(MXLNEL), CNULL*15
27 DIMENSION LELMNT(MAXELM),PLIST(MXP)
28 DATA CNULL /')NULL STRING '/
29 DATA CNUMER/'123456789-.0+'/
30 IELMNT = 0
31 LEND = LEN(CRDBUF)
32 NEXTB = 1
33 IERR = 0
34C . . . . loop over words CELMNT
35 10 CONTINUE
36 DO 100 IPOS= NEXTB,LEND
37 IBEGIN = IPOS
38 IF (CRDBUF(IPOS:IPOS).EQ.' ') GO TO 100
39 IF (CRDBUF(IPOS:IPOS).EQ.',') GO TO 250
40 GO TO 150
41 100 CONTINUE
42 GO TO 300
43 150 CONTINUE
44C found beginning of word, look for end
45 DO 180 IPOS = IBEGIN+1,LEND
46 IF (CRDBUF(IPOS:IPOS).EQ.' ') GO TO 250
47 IF (CRDBUF(IPOS:IPOS).EQ.',') GO TO 250
48 180 CONTINUE
49 IPOS = LEND+1
50 250 IEND = IPOS-1
51 IELMNT = IELMNT + 1
52 IF (IEND .GE. IBEGIN) THEN
53 CELMNT(IELMNT) = CRDBUF(IBEGIN:IEND)
54 ELSE
55 CELMNT(IELMNT) = CNULL
56 ENDIF
57 LELMNT(IELMNT) = IEND-IBEGIN+1
58 IF (LELMNT(IELMNT) .GT. MXLNEL) THEN
59 WRITE (ISYSWR, 253) CRDBUF(IBEGIN:IEND),CELMNT(IELMNT)
60 253 FORMAT (' MINUIT WARNING: INPUT DATA WORD TOO LONG.'
61 + /' ORIGINAL:',A
62 + /' TRUNCATED TO:',A)
63 LELMNT(IELMNT) = MXLNEL
64 ENDIF
65 IF (IPOS .GE. LEND) GO TO 300
66 IF (IELMNT .GE. MAXELM) GO TO 300
67C look for comma or beginning of next word
68 DO 280 IPOS= IEND+1,LEND
69 IF (CRDBUF(IPOS:IPOS) .EQ. ' ') GO TO 280
70 NEXTB = IPOS
71 IF (CRDBUF(IPOS:IPOS) .EQ. ',') NEXTB = IPOS+1
72 GO TO 10
73 280 CONTINUE
74C All elements found, join the alphabetic ones to
75C form a command
76 300 CONTINUE
77 NELMNT = IELMNT
78 COMAND = ' '
79 LNC = 1
80 PLIST(1) = 0.
81 LLIST = 0
82 IF (IELMNT .EQ. 0) GO TO 900
83 KCMND = 0
84 DO 400 IELMNT = 1, NELMNT
85 IF (CELMNT(IELMNT) .EQ. CNULL) GO TO 450
86 DO 350 IC= 1, 13
87 IF (CELMNT(IELMNT)(1:1) .EQ. CNUMER(IC:IC)) GO TO 450
88 350 CONTINUE
89 IF (KCMND .GE. MAXCWD) GO TO 400
90 LEFT = MAXCWD-KCMND
91 LTOADD = LELMNT(IELMNT)
92 IF (LTOADD .GT. LEFT) LTOADD=LEFT
93 COMAND(KCMND+1:KCMND+LTOADD) = CELMNT(IELMNT)(1:LTOADD)
94 KCMND = KCMND + LTOADD
95 IF (KCMND .EQ. MAXCWD) GO TO 400
96 KCMND = KCMND + 1
97 COMAND(KCMND:KCMND) = ' '
98 400 CONTINUE
99 LNC = KCMND
100 GO TO 900
101 450 CONTINUE
102 LNC = KCMND
103C . . . . we have come to a numeric field
104 LLIST = 0
105 DO 600 IFLD= IELMNT,NELMNT
106 LLIST = LLIST + 1
107 IF (LLIST .GT. MXP) THEN
108 NREQ = NELMNT-IELMNT+1
109 WRITE (ISYSWR,511) NREQ,MXP
110 511 FORMAT (/' MINUIT WARNING IN MNCRCK: '/ ' COMMAND HAS INPUT',I5,
111 + ' NUMERIC FIELDS, BUT MINUIT CAN ACCEPT ONLY',I3)
112 GO TO 900
113 ENDIF
114 IF (CELMNT(IFLD) .EQ. CNULL) THEN
115 PLIST(LLIST) = 0.
116 ELSE
117 READ (CELMNT(IFLD), '(BN,F19.0)',ERR=575) PLIST(LLIST)
118 ENDIF
119 GO TO 600
120 575 WRITE (ISYSWR,'(A,A,A)') ' FORMAT ERROR IN NUMERIC FIELD: "',
121 + CELMNT(IFLD)(1:LELMNT(IFLD)),'"'
122 IERR = 1
123 PLIST(LLIST) = 0.
124 600 CONTINUE
125C end loop over numeric fields
126 900 CONTINUE
127 IF (LNC .LE. 0) LNC=1
128 RETURN
129 END
Note: See TracBrowser for help on using the repository browser.