PHOS/shaker/luupda.f

   1 *CMZ :          17/07/98  15.44.34  by  Federico Carminati
   2 *-- Author :
   3 C*********************************************************************
   4
   5       SUBROUTINE LUUPDA(MUPDA,LFN)
   6
   7 C...Purpose: to facilitate the updating of particle and decay data.
   8 *KEEP,LUDAT1.
   9       COMMON /LUDAT1/ MSTU(200),PARU(200),MSTJ(200),PARJ(200)
  10       SAVE /LUDAT1/
  11 *KEEP,LUDAT2.
  12       COMMON /LUDAT2/ KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
  13       SAVE /LUDAT2/
  14 *KEEP,LUDAT3.
  15       COMMON /LUDAT3/ MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
  16       SAVE /LUDAT3/
  17 *KEEP,LUDAT4.
  18       COMMON /LUDAT4/ CHAF(500)
  19       SAVE /LUDAT4/
  20 *KEND.
  21       CHARACTER CHAF*8
  22       CHARACTER CHINL*80,CHKC*4,CHVAR(19)*9,CHLIN*72,
  23      &CHBLK(20)*72,CHOLD*12,CHTMP*12,CHNEW*12,CHCOM*12
  24       DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','PMAS(I,1)',
  25      &'PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)','MDCY(I,2)',
  26      &'MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I)  ','KFDP(I,1)',
  27      &'KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)','CHAF(I)  '/
  28
  29 C...Write information on file for editing.
  30       IF(MSTU(12).GE.1) CALL LULIST(0)
  31       IF(MUPDA.EQ.1) THEN
  32         DO 110 KC=1,MSTU(6)
  33         WRITE(LFN,1000) KC,CHAF(KC),(KCHG(KC,J1),J1=1,3),
  34      &  (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
  35         DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
  36   100   WRITE(LFN,1100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
  37      &  (KFDP(IDC,J),J=1,5)
  38   110   CONTINUE
  39
  40 C...Reset variables and read information from edited file.
  41       ELSEIF(MUPDA.EQ.2) THEN
  42         DO 120 I=1,MSTU(7)
  43         MDME(I,1)=1
  44         MDME(I,2)=0
  45         BRAT(I)=0.
  46         DO 120 J=1,5
  47   120   KFDP(I,J)=0
  48         KC=0
  49         IDC=0
  50         NDC=0
  51   130   READ(LFN,1200,END=140) CHINL
  52         IF(CHINL(2:5).NE.'    ') THEN
  53           CHKC=CHINL(2:5)
  54           IF(KC.NE.0) THEN
  55             MDCY(KC,2)=0
  56             IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC
  57             MDCY(KC,3)=NDC
  58           ENDIF
  59           READ(CHKC,1300) KC
  60           IF(KC.LE.0.OR.KC.GT.MSTU(6)) CALL LUERRM(27,
  61      &    '(LUUPDA:) Read KC code illegal, KC ='//CHKC)
  62           READ(CHINL,1000) KCR,CHAF(KC),(KCHG(KC,J1),J1=1,3),
  63      &    (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
  64           NDC=0
  65         ELSE
  66           IDC=IDC+1
  67           NDC=NDC+1
  68           IF(IDC.GE.MSTU(7)) CALL LUERRM(27,
  69      &    '(LUUPDA:) Decay data arrays full by KC ='//CHKC)
  70           READ(CHINL,1100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
  71      &    (KFDP(IDC,J),J=1,5)
  72         ENDIF
  73         GOTO 130
  74   140   MDCY(KC,2)=0
  75         IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC
  76         MDCY(KC,3)=NDC
  77
  78 C...Perform possible tests that new information is consistent.
  79         MSTJ24=MSTJ(24)
  80         MSTJ(24)=0
  81         DO 170 KC=1,MSTU(6)
  82         WRITE(CHKC,1300) KC
  83         IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
  84      &  PMAS(KC,4)).LT.0..OR.MDCY(KC,3).LT.0) CALL LUERRM(17,
  85      &  '(LUUPDA:) Mass/width/life/(# channels) wrong for KC ='//CHKC)
  86         BRSUM=0.
  87         DO 160 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
  88         IF(MDME(IDC,2).GT.80) GOTO 160
  89         KQ=KCHG(KC,1)
  90         PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
  91         MERR=0
  92         DO 150 J=1,5
  93         KP=KFDP(IDC,J)
  94         IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
  95         ELSEIF(LUCOMP(KP).EQ.0) THEN
  96           MERR=3
  97         ELSE
  98           KQ=KQ-LUCHGE(KP)
  99           PMS=PMS-ULMASS(KP)
 100         ENDIF
 101   150   CONTINUE
 102         IF(KQ.NE.0) MERR=MAX(2,MERR)
 103         IF(KFDP(IDC,2).NE.0.AND.(KC.LE.20.OR.KC.GT.40).AND.
 104      &  (KC.LE.80.OR.KC.GT.100).AND.MDME(IDC,2).NE.34.AND.
 105      &  MDME(IDC,2).NE.61.AND.PMS.LT.0.) MERR=MAX(1,MERR)
 106         IF(MERR.EQ.3) CALL LUERRM(17,
 107      &  '(LUUPDA:) Unknown particle code in decay of KC ='//CHKC)
 108         IF(MERR.EQ.2) CALL LUERRM(17,
 109      &  '(LUUPDA:) Charge not conserved in decay of KC ='//CHKC)
 110         IF(MERR.EQ.1) CALL LUERRM(7,
 111      &  '(LUUPDA:) Kinematically unallowed decay of KC ='//CHKC)
 112         BRSUM=BRSUM+BRAT(IDC)
 113   160   CONTINUE
 114         WRITE(CHTMP,1500) BRSUM
 115         IF(ABS(BRSUM).GT.0.0005.AND.ABS(BRSUM-1.).GT.0.0005) CALL
 116      &  LUERRM(7,'(LUUPDA:) Sum of branching ratios is '//CHTMP(5:12)//
 117      &  ' for KC ='//CHKC)
 118   170   CONTINUE
 119         MSTJ(24)=MSTJ24
 120
 121 C...Initialize writing of DATA statements for inclusion in program.
 122       ELSEIF(MUPDA.EQ.3) THEN
 123         DO 240 IVAR=1,19
 124         NDIM=MSTU(6)
 125         IF(IVAR.GE.11.AND.IVAR.LE.18) NDIM=MSTU(7)
 126         NLIN=1
 127         CHLIN=' '
 128         CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I=   1,    )/'
 129         LLIN=35
 130         CHOLD='START'
 131
 132 C...Loop through variables for conversion to characters.
 133         DO 220 IDIM=1,NDIM
 134         IF(IVAR.EQ.1) WRITE(CHTMP,1400) KCHG(IDIM,1)
 135         IF(IVAR.EQ.2) WRITE(CHTMP,1400) KCHG(IDIM,2)
 136         IF(IVAR.EQ.3) WRITE(CHTMP,1400) KCHG(IDIM,3)
 137         IF(IVAR.EQ.4) WRITE(CHTMP,1500) PMAS(IDIM,1)
 138         IF(IVAR.EQ.5) WRITE(CHTMP,1500) PMAS(IDIM,2)
 139         IF(IVAR.EQ.6) WRITE(CHTMP,1500) PMAS(IDIM,3)
 140         IF(IVAR.EQ.7) WRITE(CHTMP,1500) PMAS(IDIM,4)
 141         IF(IVAR.EQ.8) WRITE(CHTMP,1400) MDCY(IDIM,1)
 142         IF(IVAR.EQ.9) WRITE(CHTMP,1400) MDCY(IDIM,2)
 143         IF(IVAR.EQ.10) WRITE(CHTMP,1400) MDCY(IDIM,3)
 144         IF(IVAR.EQ.11) WRITE(CHTMP,1400) MDME(IDIM,1)
 145         IF(IVAR.EQ.12) WRITE(CHTMP,1400) MDME(IDIM,2)
 146         IF(IVAR.EQ.13) WRITE(CHTMP,1500) BRAT(IDIM)
 147         IF(IVAR.EQ.14) WRITE(CHTMP,1400) KFDP(IDIM,1)
 148         IF(IVAR.EQ.15) WRITE(CHTMP,1400) KFDP(IDIM,2)
 149         IF(IVAR.EQ.16) WRITE(CHTMP,1400) KFDP(IDIM,3)
 150         IF(IVAR.EQ.17) WRITE(CHTMP,1400) KFDP(IDIM,4)
 151         IF(IVAR.EQ.18) WRITE(CHTMP,1400) KFDP(IDIM,5)
 152         IF(IVAR.EQ.19) CHTMP=CHAF(IDIM)
 153
 154 C...Length of variable, trailing decimal zeros, quotation marks.
 155         LLOW=1
 156         LHIG=1
 157         DO 180 LL=1,12
 158         IF(CHTMP(13-LL:13-LL).NE.' ') LLOW=13-LL
 159   180   IF(CHTMP(LL:LL).NE.' ') LHIG=LL
 160         CHNEW=CHTMP(LLOW:LHIG)//' '
 161         LNEW=1+LHIG-LLOW
 162         IF((IVAR.GE.4.AND.IVAR.LE.7).OR.IVAR.EQ.13) THEN
 163           LNEW=LNEW+1
 164   190     LNEW=LNEW-1
 165           IF(CHNEW(LNEW:LNEW).EQ.'0') GOTO 190
 166           IF(LNEW.EQ.1) CHNEW(1:2)='0.'
 167           IF(LNEW.EQ.1) LNEW=2
 168         ELSEIF(IVAR.EQ.19) THEN
 169           DO 200 LL=LNEW,1,-1
 170           IF(CHNEW(LL:LL).EQ.'''') THEN
 171             CHTMP=CHNEW
 172             CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
 173             LNEW=LNEW+1
 174           ENDIF
 175   200     CONTINUE
 176           CHTMP=CHNEW
 177           CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
 178           LNEW=LNEW+2
 179         ENDIF
 180
 181 C...Form composite character string, often including repetition counter.
 182         IF(CHNEW.NE.CHOLD) THEN
 183           NRPT=1
 184           CHOLD=CHNEW
 185           CHCOM=CHNEW
 186           LCOM=LNEW
 187         ELSE
 188           LRPT=LNEW+1
 189           IF(NRPT.GE.2) LRPT=LNEW+3
 190           IF(NRPT.GE.10) LRPT=LNEW+4
 191           IF(NRPT.GE.100) LRPT=LNEW+5
 192           IF(NRPT.GE.1000) LRPT=LNEW+6
 193           LLIN=LLIN-LRPT
 194           NRPT=NRPT+1
 195           WRITE(CHTMP,1400) NRPT
 196           LRPT=1
 197           IF(NRPT.GE.10) LRPT=2
 198           IF(NRPT.GE.100) LRPT=3
 199           IF(NRPT.GE.1000) LRPT=4
 200           CHCOM(1:LRPT+1+LNEW)=CHTMP(13-LRPT:12)//'*'//CHNEW(1:LNEW)
 201           LCOM=LRPT+1+LNEW
 202         ENDIF
 203
 204 C...Add characters to end of line, to new line (after storing old line),
 205 C...or to new block of lines (after writing old block).
 206         IF(LLIN+LCOM.LE.70) THEN
 207           CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
 208           LLIN=LLIN+LCOM+1
 209         ELSEIF(NLIN.LE.19) THEN
 210           CHLIN(LLIN+1:72)=' '
 211           CHBLK(NLIN)=CHLIN
 212           NLIN=NLIN+1
 213           CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
 214           LLIN=6+LCOM+1
 215         ELSE
 216           CHLIN(LLIN:72)='/'//' '
 217           CHBLK(NLIN)=CHLIN
 218           WRITE(CHTMP,1400) IDIM-NRPT
 219           CHBLK(1)(30:33)=CHTMP(9:12)
 220           DO 210 ILIN=1,NLIN
 221   210     WRITE(LFN,1600) CHBLK(ILIN)
 222           NLIN=1
 223           CHLIN=' '
 224           CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//',I=    ,    )/'//
 225      &    CHCOM(1:LCOM)//','
 226           WRITE(CHTMP,1400) IDIM-NRPT+1
 227           CHLIN(25:28)=CHTMP(9:12)
 228           LLIN=35+LCOM+1
 229         ENDIF
 230   220   CONTINUE
 231
 232 C...Write final block of lines.
 233         CHLIN(LLIN:72)='/'//' '
 234         CHBLK(NLIN)=CHLIN
 235         WRITE(CHTMP,1400) NDIM
 236         CHBLK(1)(30:33)=CHTMP(9:12)
 237         DO 230 ILIN=1,NLIN
 238   230   WRITE(LFN,1600) CHBLK(ILIN)
 239   240   CONTINUE
 240       ENDIF
 241
 242 C...Formats for reading and writing particle data.
 243  1000 FORMAT(1X,I4,2X,A8,3I3,3F12.5,2X,F12.5,I3)
 244  1100 FORMAT(5X,2I5,F12.5,5I8)
 245  1200 FORMAT(A80)
 246  1300 FORMAT(I4)
 247  1400 FORMAT(I12)
 248  1500 FORMAT(F12.5)
 249  1600 FORMAT(A72)
 250
 251       RETURN
 252       END