SUBROUTINE addcmp(instrg, lenn, batchparam,qupdat) INCLUDE '../../inc/xspec.inc' CHARACTER instrg*(*),batchparam*(*) INTEGER lenn LOGICAL qupdat c--- c XSPEC subroutine to add a component to the current model c--- c instrg c*(*) i/r: command parse string c lenn i i/r: command string parse position c qupdate l4 r: update fit stats, etc, on return? c--- c 13 Feb 1990 - kaa c Only allows one component to be added at a time c 4 July 1991 - kaa c One extra component for each data group INCLUDE 'mtypes.inc' REAL emx, emn INTEGER jkey, nret, iflag, idelim, idt, igroup, ngroup INTEGER idkey, jksave, jmpar, ikey, ilen INTEGER ierr, modtyp, begpar, endpar INTEGER pretyp, postyp, pregrp, posgrp CHARACTER cmpnam*255, modlnm*8, tblstr*255, tabtyp*3, wrtstr*1024 LOGICAL qback INTEGER cgbmpr, cgempr, cgncmp, dgndtg INTEGER cgmgrp, ggecmp, cgktyp, lenact LOGICAL cgisad, cgisbg, qmerr EXTERNAL dgndtg, ggecmp, cgisad, cgisbg EXTERNAL cgbmpr, cgempr, cgncmp, cgmgrp, cgktyp c Check whether we can add extra components IF ((cgncmp()+dgndtg()).GT.MAXMOD) THEN WRITE (wrtstr, *) & 'Sorry, maximum number of components already in use' CALL xwrite(wrtstr, 2) RETURN ENDIF c Parse the command to get the component position. Check that it is c valid - ie part of the first data group 50 CONTINUE CALL xgtint(instrg, lenn, 1, 'Component position ', 1, jkey, nret, & iflag, idelim) IF (iflag.NE.0) RETURN IF (jkey .GT. cgncmp()/dgndtg() + 1) THEN CALL xwrite('Component position must be part of first group', & 2) WRITE(wrtstr,'(''Valid range is 1 - '', i2)') cgncmp()/dgndtg()+1 CALL xwrite(wrtstr, 2) CALL xinfix('Component position ', instrg, lenn, iflag) IF (iflag .NE. 0) RETURN GOTO 50 ENDIF c Parse the command string for the component name. CALL xgtstr(instrg, lenn, 1, 'Component name ', 1, cmpnam, nret, & iflag, idelim) IF (iflag.NE.0) RETURN c Check for the /b qualifier indicating a background component ilen = lenact(cmpnam) IF( cmpnam(ilen-1:ilen) .EQ. '/b' ) THEN cmpnam = cmpnam(:ilen-2) qback = .TRUE. ELSE qback = .FALSE. ENDIF c Find the model info for the requested component CALL mtchmd(cmpnam, modlnm, modtyp, jmpar, emx, emn, tblstr, & tabtyp, qmerr, ierr) IF ( ierr .NE. 0 ) RETURN IF ( qback .AND. ADDMDL .NE. modtyp ) THEN CALL xwrite(' Background components must be'// & ' from the additive model list', 10) RETURN ENDIF idkey = cgncmp()/dgndtg() c find current number of additive groups ngroup= 0 DO ikey = 1, ggecmp(1) ngroup = max(ngroup, cgmgrp(ikey)) ENDDO c Check on proper placement of component and decide which data group c it should go in. In general try to associate component with the c one to its right. c Set up for testing to decide on data group. Background models are c treated as additive models in the overall multiplicative group. c Set up reasonable defaults for when the component to be added is in c the first or the last position. pregrp = -1 posgrp = -1 pretyp = ADDMDL postyp = ADDMDL IF( jkey .NE. 1 )THEN pregrp = cgmgrp(jkey-1) IF( pregrp .EQ. 0 ) pregrp = -1 pretyp = cgktyp(jkey-1) IF( pretyp .EQ. BKGMDL ) pretyp = ADDMDL ENDIF IF( jkey .LE. ggecmp(1) )THEN posgrp = cgmgrp(jkey) IF( posgrp .EQ. 0 ) posgrp = -1 postyp = cgktyp(jkey) IF( postyp .EQ. BKGMDL ) postyp = ADDMDL ENDIF c Branch here if component is placed on the boudary between two c additive groups. IF( posgrp .NE. pregrp )THEN IF( modtyp .EQ. ADDMDL )THEN igroup = ngroup + 1 ELSE igroup = posgrp ENDIF c Branch here if the component is within an additive group. ELSE IF( postyp .EQ. ADDMDL .AND. pretyp .EQ. ADDMDL .AND. & modtyp .EQ. MULMDL )THEN CALL xwrite(' Cannot place multiplicative model between'// & ' two additive type models. No model added.', 10) RETURN ELSEIF( postyp .EQ. ADDMDL .AND. pretyp .EQ. ADDMDL .AND. & modtyp .EQ. CONMDL )THEN CALL xwrite(' Cannot place convolution model between'// & ' two additive type models. No model added.', 10) RETURN ELSEIF( postyp .EQ. MULMDL .AND. pretyp .EQ. MULMDL .AND. & modtyp .EQ. ADDMDL )THEN CALL xwrite(' Cannot place additive model between'// & ' two multiplicative type models. No model added.', 10) RETURN ELSE igroup = posgrp ENDIF ENDIF IF( qback )THEN IF( igroup .NE. -1 .AND. jkey .LE. ggecmp(1) )THEN CALL xwrite(' Bad placement of background model.', 10) CALL xwrite(' No model added.', 10) RETURN ELSE igroup = 0 modtyp = BKGMDL ENDIF ENDIF c Create the component in the first data group CALL cpcmod(jkey, ierr) c Load the contents and set the data group CALL cpload(jkey, modtyp, modlnm, jmpar, qback, emx, emn, & tblstr, tabtyp, qmerr, ierr) CALL cpmgrp(jkey, igroup, ierr) c Now replicate the model for the other data groups jksave = jkey DO idt = 2, dgndtg() c Set the component position for this data group. Note that the component c keys are reset each time round hence the extra 1. jkey = jkey + idkey + 1 c Create the component and copy that for the first data group CALL cpcmod(jkey, ierr) CALL cpcpmd(jksave, jkey, ierr) ENDDO c initialize parameters for new component. recalculate idkey because c new components have been created. idkey = cgncmp()/dgndtg() jkey = jksave - idkey DO idt = 1, dgndtg() jkey = jkey + idkey CALL inipar(jkey, 0) ENDDO c write out 'model' and 'param def' history packages CALL wmohis() CALL wpahis() c Loop round the data groups setting parameters jkey = jksave - idkey DO idt = 1, dgndtg() jkey = jkey + idkey begpar = cgbmpr(jkey) endpar = cgempr(jkey) c If additive component also set the normilization IF( cgisad(jkey) .OR. cgisbg(jkey) ) endpar = endpar+1 IF( idt .GT. 1 )THEN wrtstr = wrtstr(:lenact(wrtstr))//',' WRITE( wrtstr(lenact(wrtstr)+1:), '(i3,''-'',i3)' ) & begpar, endpar ELSE WRITE( wrtstr, '(i3,''-'',i3)' ) begpar, endpar ENDIF ENDDO CALL squeez(wrtstr,' ',-1,ilen) wrtstr = ' '//wrtstr(1:ilen) CALL xwrite(' ADDCMP: String for setpar :'//wrtstr, 25) ilen = 1 CALL setpar(wrtstr, batchparam, .FALSE., qupdat) c write out a history record: CALL wprhis() RETURN END