hijing/src/luupda.f

0001
0002 C*********************************************************************
0003
0004       SUBROUTINE LUUPDA(MUPDA,LFN)
0005
0006 C...Purpose: to facilitate the updating of particle and decay data.
0007       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0008       SAVE /LUDAT1/
0009       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0010       SAVE /LUDAT2/
0011       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
0012       SAVE /LUDAT3/
0013       COMMON/LUDAT4/CHAF(500)
0014       CHARACTER CHAF*8
0015       SAVE /LUDAT4/
0016       CHARACTER CHINL*80,CHKC*4,CHVAR(19)*9,CHLIN*72,
0017      &CHBLK(20)*72,CHOLD*12,CHTMP*12,CHNEW*12,CHCOM*12
0018       DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','PMAS(I,1)',
0019      &'PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)','MDCY(I,2)',
0020      &'MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I)  ','KFDP(I,1)',
0021      &'KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)','CHAF(I)  '/
0022
0023 C...Write information on file for editing.
0024       IF(MSTU(12).GE.1) CALL LULIST(0)
0025       IF(MUPDA.EQ.1) THEN
0026         DO 110 KC=1,MSTU(6)
0027         WRITE(LFN,1000) KC,CHAF(KC),(KCHG(KC,J1),J1=1,3),
0028      &  (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
0029         DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
0030   100   WRITE(LFN,1100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
0031      &  (KFDP(IDC,J),J=1,5)
0032   110   CONTINUE
0033
0034 C...Reset variables and read information from edited file.
0035       ELSEIF(MUPDA.EQ.2) THEN
0036         DO 120 I=1,MSTU(7)
0037         MDME(I,1)=1
0038         MDME(I,2)=0
0039         BRAT(I)=0.
0040         DO 120 J=1,5
0041   120   KFDP(I,J)=0
0042         KC=0
0043         IDC=0
0044         NDC=0
0045   130   READ(LFN,1200,END=140) CHINL
0046         IF(CHINL(2:5).NE.'    ') THEN
0047           CHKC=CHINL(2:5)
0048           IF(KC.NE.0) THEN
0049             MDCY(KC,2)=0
0050             IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC
0051             MDCY(KC,3)=NDC
0052           ENDIF
0053           READ(CHKC,1300) KC
0054           IF(KC.LE.0.OR.KC.GT.MSTU(6)) CALL LUERRM(27,
0055      &    '(LUUPDA:) Read KC code illegal, KC ='//CHKC)
0056           READ(CHINL,1000) KCR,CHAF(KC),(KCHG(KC,J1),J1=1,3),
0057      &    (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
0058           NDC=0
0059         ELSE
0060           IDC=IDC+1
0061           NDC=NDC+1
0062           IF(IDC.GE.MSTU(7)) CALL LUERRM(27,
0063      &    '(LUUPDA:) Decay data arrays full by KC ='//CHKC)
0064           READ(CHINL,1100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
0065      &    (KFDP(IDC,J),J=1,5)
0066         ENDIF
0067         GOTO 130
0068   140   MDCY(KC,2)=0
0069         IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC
0070         MDCY(KC,3)=NDC
0071
0072 C...Perform possible tests that new information is consistent.
0073         MSTJ24=MSTJ(24)
0074         MSTJ(24)=0
0075         DO 170 KC=1,MSTU(6)
0076         WRITE(CHKC,1300) KC
0077         IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
0078      &  PMAS(KC,4)).LT.0..OR.MDCY(KC,3).LT.0) CALL LUERRM(17,
0079      &  '(LUUPDA:) Mass/width/life/(# channels) wrong for KC ='//CHKC)
0080         BRSUM=0.
0081         DO 160 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
0082         IF(MDME(IDC,2).GT.80) GOTO 160
0083         KQ=KCHG(KC,1)
0084         PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
0085         MERR=0
0086         DO 150 J=1,5
0087         KP=KFDP(IDC,J)
0088         IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
0089         ELSEIF(LUCOMP(KP).EQ.0) THEN
0090           MERR=3
0091         ELSE
0092           KQ=KQ-LUCHGE(KP)
0093           PMS=PMS-ULMASS(KP)
0094         ENDIF
0095   150   CONTINUE
0096         IF(KQ.NE.0) MERR=MAX(2,MERR)
0097         IF(KFDP(IDC,2).NE.0.AND.(KC.LE.20.OR.KC.GT.40).AND.
0098      &  (KC.LE.80.OR.KC.GT.100).AND.MDME(IDC,2).NE.34.AND.
0099      &  MDME(IDC,2).NE.61.AND.PMS.LT.0.) MERR=MAX(1,MERR)
0100         IF(MERR.EQ.3) CALL LUERRM(17,
0101      &  '(LUUPDA:) Unknown particle code in decay of KC ='//CHKC)
0102         IF(MERR.EQ.2) CALL LUERRM(17,
0103      &  '(LUUPDA:) Charge not conserved in decay of KC ='//CHKC)
0104         IF(MERR.EQ.1) CALL LUERRM(7,
0105      &  '(LUUPDA:) Kinematically unallowed decay of KC ='//CHKC)
0106         BRSUM=BRSUM+BRAT(IDC)
0107   160   CONTINUE
0108         WRITE(CHTMP,1500) BRSUM
0109         IF(ABS(BRSUM).GT.0.0005.AND.ABS(BRSUM-1.).GT.0.0005) CALL
0110      &  LUERRM(7,'(LUUPDA:) Sum of branching ratios is '//CHTMP(5:12)//
0111      &  ' for KC ='//CHKC)
0112   170   CONTINUE
0113         MSTJ(24)=MSTJ24
0114
0115 C...Initialize writing of DATA statements for inclusion in program.
0116       ELSEIF(MUPDA.EQ.3) THEN
0117         DO 240 IVAR=1,19
0118         NDIM=MSTU(6)
0119         IF(IVAR.GE.11.AND.IVAR.LE.18) NDIM=MSTU(7)
0120         NLIN=1
0121         CHLIN=' '
0122         CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I=   1,    )/'
0123         LLIN=35
0124         CHOLD='START'
0125
0126 C...Loop through variables for conversion to characters.
0127         DO 220 IDIM=1,NDIM
0128         IF(IVAR.EQ.1) WRITE(CHTMP,1400) KCHG(IDIM,1)
0129         IF(IVAR.EQ.2) WRITE(CHTMP,1400) KCHG(IDIM,2)
0130         IF(IVAR.EQ.3) WRITE(CHTMP,1400) KCHG(IDIM,3)
0131         IF(IVAR.EQ.4) WRITE(CHTMP,1500) PMAS(IDIM,1)
0132         IF(IVAR.EQ.5) WRITE(CHTMP,1500) PMAS(IDIM,2)
0133         IF(IVAR.EQ.6) WRITE(CHTMP,1500) PMAS(IDIM,3)
0134         IF(IVAR.EQ.7) WRITE(CHTMP,1500) PMAS(IDIM,4)
0135         IF(IVAR.EQ.8) WRITE(CHTMP,1400) MDCY(IDIM,1)
0136         IF(IVAR.EQ.9) WRITE(CHTMP,1400) MDCY(IDIM,2)
0137         IF(IVAR.EQ.10) WRITE(CHTMP,1400) MDCY(IDIM,3)
0138         IF(IVAR.EQ.11) WRITE(CHTMP,1400) MDME(IDIM,1)
0139         IF(IVAR.EQ.12) WRITE(CHTMP,1400) MDME(IDIM,2)
0140         IF(IVAR.EQ.13) WRITE(CHTMP,1500) BRAT(IDIM)
0141         IF(IVAR.EQ.14) WRITE(CHTMP,1400) KFDP(IDIM,1)
0142         IF(IVAR.EQ.15) WRITE(CHTMP,1400) KFDP(IDIM,2)
0143         IF(IVAR.EQ.16) WRITE(CHTMP,1400) KFDP(IDIM,3)
0144         IF(IVAR.EQ.17) WRITE(CHTMP,1400) KFDP(IDIM,4)
0145         IF(IVAR.EQ.18) WRITE(CHTMP,1400) KFDP(IDIM,5)
0146         IF(IVAR.EQ.19) CHTMP=CHAF(IDIM)
0147
0148 C...Length of variable, trailing decimal zeros, quotation marks.
0149         LLOW=1
0150         LHIG=1
0151         DO 180 LL=1,12
0152         IF(CHTMP(13-LL:13-LL).NE.' ') LLOW=13-LL
0153   180   IF(CHTMP(LL:LL).NE.' ') LHIG=LL
0154         CHNEW=CHTMP(LLOW:LHIG)//' '
0155         LNEW=1+LHIG-LLOW
0156         IF((IVAR.GE.4.AND.IVAR.LE.7).OR.IVAR.EQ.13) THEN
0157           LNEW=LNEW+1
0158   190     LNEW=LNEW-1
0159           IF(CHNEW(LNEW:LNEW).EQ.'0') GOTO 190
0160           IF(LNEW.EQ.1) CHNEW(1:2)='0.'
0161           IF(LNEW.EQ.1) LNEW=2
0162         ELSEIF(IVAR.EQ.19) THEN
0163           DO 200 LL=LNEW,1,-1
0164           IF(CHNEW(LL:LL).EQ.'''') THEN
0165             CHTMP=CHNEW
0166             CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
0167             LNEW=LNEW+1
0168           ENDIF
0169   200     CONTINUE
0170           CHTMP=CHNEW
0171           CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
0172           LNEW=LNEW+2
0173         ENDIF
0174
0175 C...Form composite character string, often including repetition counter.
0176         IF(CHNEW.NE.CHOLD) THEN
0177           NRPT=1
0178           CHOLD=CHNEW
0179           CHCOM=CHNEW
0180           LCOM=LNEW
0181         ELSE
0182           LRPT=LNEW+1
0183           IF(NRPT.GE.2) LRPT=LNEW+3
0184           IF(NRPT.GE.10) LRPT=LNEW+4
0185           IF(NRPT.GE.100) LRPT=LNEW+5
0186           IF(NRPT.GE.1000) LRPT=LNEW+6
0187           LLIN=LLIN-LRPT
0188           NRPT=NRPT+1
0189           WRITE(CHTMP,1400) NRPT
0190           LRPT=1
0191           IF(NRPT.GE.10) LRPT=2
0192           IF(NRPT.GE.100) LRPT=3
0193           IF(NRPT.GE.1000) LRPT=4
0194           CHCOM(1:LRPT+1+LNEW)=CHTMP(13-LRPT:12)//'*'//CHNEW(1:LNEW)
0195           LCOM=LRPT+1+LNEW
0196         ENDIF
0197
0198 C...Add characters to end of line, to new line (after storing old line),
0199 C...or to new block of lines (after writing old block).
0200         IF(LLIN+LCOM.LE.70) THEN
0201           CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
0202           LLIN=LLIN+LCOM+1
0203         ELSEIF(NLIN.LE.19) THEN
0204           CHLIN(LLIN+1:72)=' '
0205           CHBLK(NLIN)=CHLIN
0206           NLIN=NLIN+1
0207           CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
0208           LLIN=6+LCOM+1
0209         ELSE
0210           CHLIN(LLIN:72)='/'//' '
0211           CHBLK(NLIN)=CHLIN
0212           WRITE(CHTMP,1400) IDIM-NRPT
0213           CHBLK(1)(30:33)=CHTMP(9:12)
0214           DO 210 ILIN=1,NLIN
0215   210     WRITE(LFN,1600) CHBLK(ILIN)
0216           NLIN=1
0217           CHLIN=' '
0218           CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//',I=    ,    )/'//
0219      &    CHCOM(1:LCOM)//','
0220           WRITE(CHTMP,1400) IDIM-NRPT+1
0221           CHLIN(25:28)=CHTMP(9:12)
0222           LLIN=35+LCOM+1
0223         ENDIF
0224   220   CONTINUE
0225
0226 C...Write final block of lines.
0227         CHLIN(LLIN:72)='/'//' '
0228         CHBLK(NLIN)=CHLIN
0229         WRITE(CHTMP,1400) NDIM
0230         CHBLK(1)(30:33)=CHTMP(9:12)
0231         DO 230 ILIN=1,NLIN
0232   230   WRITE(LFN,1600) CHBLK(ILIN)
0233   240   CONTINUE
0234       ENDIF
0235
0236 C...Formats for reading and writing particle data.
0237  1000 FORMAT(1X,I4,2X,A8,3I3,3F12.5,2X,F12.5,I3)
0238  1100 FORMAT(5X,2I5,F12.5,5I8)
0239  1200 FORMAT(A80)
0240  1300 FORMAT(I4)
0241  1400 FORMAT(I12)
0242  1500 FORMAT(F12.5)
0243  1600 FORMAT(A72)
0244
0245       RETURN
0246       END