pythiaeRHIC/pythia/pyonof.f

0001
0002 C*********************************************************************
0003
0004 C...PYONOF
0005 C...Switches on and off decay channel by search for match.
0006
0007       SUBROUTINE PYONOF(CHIN)
0008
0009 C...Double precision and integer declarations.
0010       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
0011       IMPLICIT INTEGER(I-N)
0012       INTEGER PYK,PYCHGE,PYCOMP
0013 C...Commonblocks.
0014       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0015       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
0016       SAVE /PYDAT1/,/PYDAT3/
0017 C...Local arrays and character variables.
0018       INTEGER KFCMP(10),KFTMP(10)
0019       CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
0020      &CHALP(2)*26
0021       DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
0022      &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
0023
0024 C...Determine length of character variable.
0025       CHTMP=CHIN//' '
0026       LBEG=0
0027   100 LBEG=LBEG+1
0028       IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
0029       LEND=LBEG-1
0030   105 LEND=LEND+1
0031       IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
0032   110 LEND=LEND-1
0033       IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
0034       LEN=1+LEND-LBEG
0035       CHFIX(1:LEN)=CHTMP(LBEG:LEND)
0036
0037 C...Find colon separator and particle code.
0038       LCOLON=0
0039   120 LCOLON=LCOLON+1
0040       IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
0041       CHCODE=' '
0042       CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
0043       READ(CHCODE,'(I8)',ERR=300) KF
0044       KC=PYCOMP(KF)
0045
0046 C...Done if unknown code or no decay channels.
0047       IF(KC.EQ.0) THEN
0048         CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
0049         RETURN
0050       ENDIF
0051       IDCBEG=MDCY(KC,2)
0052       IDCLEN=MDCY(KC,3)
0053       IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
0054         CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
0055         RETURN
0056       ENDIF
0057
0058 C...Find command name up to blank or equal sign.
0059       LSEP=LCOLON
0060   130 LSEP=LSEP+1
0061       IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
0062      &CHFIX(LSEP:LSEP).NE.'=') GOTO 130
0063       CHMODE=' '
0064       LMODE=LSEP-LCOLON-1
0065       CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)
0066
0067 C...Convert to uppercase.
0068       DO 150 LCOM=1,LMODE
0069         DO 140 LALP=1,26
0070           IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP))
0071      &    CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
0072   140   CONTINUE
0073   150 CONTINUE
0074
0075 C...Identify command. Failed if not identified.
0076       MODE=0
0077       IF(CHMODE.EQ.'ALLOFF') MODE=1
0078       IF(CHMODE.EQ.'ALLON') MODE=2
0079       IF(CHMODE.EQ.'OFFIFANY') MODE=3
0080       IF(CHMODE.EQ.'ONIFANY') MODE=4
0081       IF(CHMODE.EQ.'OFFIFALL') MODE=5
0082       IF(CHMODE.EQ.'ONIFALL') MODE=6
0083       IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
0084       IF(CHMODE.EQ.'ONIFMATCH') MODE=8
0085       IF(MODE.EQ.0) THEN
0086         CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
0087         RETURN
0088       ENDIF
0089
0090 C...Simple cases when all on or all off.
0091       IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
0092         WRITE(MSTU(11),1000) KF,CHMODE
0093         DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
0094           IF(MDME(IDC,1).LT.0) GOTO 160
0095           MDME(IDC,1)=MODE-1
0096   160   CONTINUE
0097         RETURN
0098       ENDIF
0099
0100 C...Identify matching list.
0101       NCMP=0
0102       LBEG=LSEP
0103   170 LBEG=LBEG+1
0104       IF(LBEG.GT.LEN) GOTO 190
0105       IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
0106      &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
0107       LEND=LBEG-1
0108   180 LEND=LEND+1
0109       IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
0110      &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
0111       IF(LEND.LT.LEN) LEND=LEND-1
0112       CHCODE=' '
0113       CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
0114       READ(CHCODE,'(I8)',ERR=300) KFREAD
0115       NCMP=NCMP+1
0116       KFCMP(NCMP)=IABS(KFREAD)
0117       LBEG=LEND
0118       IF(NCMP.LT.10) GOTO 170
0119   190 CONTINUE
0120       WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)
0121
0122 C...Only one matching required.
0123       IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
0124         DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
0125           IF(MDME(IDC,1).LT.0) GOTO 220
0126           DO 210 IKF=1,5
0127             KFNOW=IABS(KFDP(IDC,IKF))
0128             IF(KFNOW.EQ.0) GOTO 210
0129             DO 200 ICMP=1,NCMP
0130               IF(KFCMP(ICMP).EQ.KFNOW) THEN
0131                 MDME(IDC,1)=MODE-3
0132                 GOTO 220
0133               ENDIF
0134   200      CONTINUE
0135   210     CONTINUE
0136   220   CONTINUE
0137         RETURN
0138       ENDIF
0139
0140 C...Multiple matchings required.
0141       DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
0142         IF(MDME(IDC,1).LT.0) GOTO 260
0143         NTMP=NCMP
0144         DO 230 ITMP=1,NTMP
0145           KFTMP(ITMP)=KFCMP(ITMP)
0146   230   CONTINUE
0147         NFIN=0
0148         DO 250 IKF=1,5
0149           KFNOW=IABS(KFDP(IDC,IKF))
0150           IF(KFNOW.EQ.0) GOTO 250
0151           NFIN=NFIN+1
0152           DO 240 ITMP=1,NTMP
0153             IF(KFTMP(ITMP).EQ.KFNOW) THEN
0154               KFTMP(ITMP)=KFTMP(NTMP)
0155               NTMP=NTMP-1
0156               GOTO 250
0157             ENDIF
0158   240     CONTINUE
0159   250   CONTINUE
0160         IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
0161         IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7)
0162      &  MDME(IDC,1)=MODE-7
0163   260 CONTINUE
0164       RETURN
0165
0166 C...Error exit for impossible read of particle code.
0167   300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
0168      &//CHCODE)
0169
0170 C...Formats for output.
0171  1000 FORMAT(' Decays for',I8,' set ',A10)
0172  1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)
0173
0174       RETURN
0175       END