C C C This code is distributed under the terms and conditions of the C CCP4 licence agreement as `Part 2' (Annex 2) software. C A copy of the CCP4 licence can be obtained by writing to the C CCP4 Secretary, Daresbury Laboratory, Warrington WA4 4AD, UK. C SUBROUTINE RCARD C C---Read instructions and save them in common blocks for future use INCLUDE 'atom_com.fh' INCLUDE 'pls_incl.fh' INCLUDE 'refi_flags.fh' INCLUDE 'cif_incl.fh' INCLUDE 'celsym.fh' INCLUDE 'monitor.fh' INCLUDE 'weights.fh' INCLUDE 'vitals.fh' INCLUDE 'agreem.fh' INCLUDE 'const.fh' INCLUDE 'tls.fh' INCLUDE 'rharvest.fh' INCLUDE 'makecif.fh' INCLUDE 'solvent.fh' INCLUDE 'map_params.fh' PARAMETER (NPARS = 200) INTEGER MCOLS PARAMETER (MCOLS = 200) INTEGER MSETS PARAMETER (MSETS=MCOLS) C c---Things for parser CHARACTER LINE*600,KEY*4,CVALUE(NPARS)*4 INTEGER IBEG(NPARS),IEND(NPARS),IDEC(NPARS),ITYP(NPARS) REAL FVALUE(NPARS) LOGICAL LEND C INTEGER NERROR,INCS_R,INCS_C LOGICAL LPRINT CHARACTER LABIN_SAVE*600,LABOUT_SAVE*600 C C----Harvesting stuff C INTEGER NDATASETS,ISETS(MSETS),ISET,CSETID(MCOLS),CSETOUT(MCOLS), + SETID REAL DATCELL,DATWAVE CHARACTER*64 PNAME,XNAME,DNAME,PNAME_OUT,XNAME_OUT,DNAME_OUT COMMON /MTZSET/ NDATASETS,PNAME(MSETS),XNAME(MSETS),DNAME(MSETS), + PNAME_OUT(MCOLS),XNAME_OUT(MCOLS),DNAME_OUT(MCOLS), + DATCELL(6,MSETS),DATWAVE(MSETS) INTEGER ITOK,ITK C C--- NERROR = 0 NSMULT = 1 C LABIN_SAVE = ' ' LABOUT_SAVE = ' ' NUNREC = 0 INCS_R = 0 INCS_C = 0 C C--- PARSER 10 CONTINUE IERROR = 0 LINE = ' ' KEY = ' ' NTOK = NPARS LPRINT = .TRUE. CALL PARSER(KEY,LINE,IBEG,IEND,ITYP,FVALUE,CVALUE,IDEC,NTOK,LEND, + LPRINT) IF(LEND) GOTO 999 C C---Print instruction line with hyper link if necessary cd CALL PARSER_PRINT(KEY,LINE) C c---Convert all CVALUEs to uppercase CALL CCPUPC(KEY) DO IKEY=2,NTOK CALL CCPUPC(CVALUE(IKEY)) ENDDO c C---Start interpretation of keywords C C---Harvesting first C=========================================================== C C---- harvest C C---- PRIVATE [priv] flag only C ======= C if present sets dir access for first C open of $HOME/DepositFiles to drwx------ C default is drwxr-xr-x C C IF (KEY .eq. 'PRIV') THEN PRIVATE = .true. GO TO 10 C C---- USECWD [usec] Flag only C ====== C if present file is opened in current working directory C default is o/p file to C $HOME/DepositFiles/ProjectName/DataSetName.ProgramName C ELSE IF (KEY .eq. 'USEC') THEN USECWD = .true. GO TO 10 C C---- PROJECTNAME [pname] C =========== C C if given with DATASET then harvest will o/p a file C this project_name should be always used for the C one structure determination C no default C ELSE IF (KEY .eq. 'PNAM') THEN PNAME_KEYWRD = LINE(IBEG(2) :IEND(2)) got_pname = .true. GO TO 10 C C---- DATASETNAME [dname] C =========== C C if given with PROJECT then harvest will o/p a file C this dataset_name is the name of one of the diffraction C data sets used in a particular project C no default C ELSE IF (KEY .eq. 'DNAM') THEN DNAME_KEYWRD = LINE(IBEG(2) :IEND(2)) got_dname = .true. GO TO 10 C C---- ROWLIMIT [rsize] C ======== C C if given sets the number of characters in a row C for the output file, default is 132 C TRUE mmcif default is 80 C ELSE IF (KEY .eq. 'RSIZ') THEN NROWLIMIT = 132 IF (NTOK.GE.2) CALL GTNINT(2,1,NROWLIMIT,NTOK,ITYP,FVALUE) GO TO 10 C C---- NOHARVEST C ======== C C disable writing of harvest files C ELSE IF (KEY .eq. 'NOHA') THEN NOHARVEST = .true. GO TO 10 C C---- harvest ELSEIF(KEY.EQ.'MODE') THEN C c----'MODE" Read action mode. Default is individual atomic reifnement CALL CCPUPC(LINE) MODE = 'HKRF' IF(NTOK.GE.2) MODE = LINE (IBEG(2):IEND(2)) IF(MODE.EQ.'RIGI'.OR.MODE.EQ.'TLSR') REFID = 'UNRE' GOTO 10 ELSEIF(KEY.EQ.'TITL') THEN GOTO 10 C c---Parameters controlling phased refinement ELSEIF(KEY.EQ.'PHAS') THEN ITOK = 2 CALL READ_PHFACTORS(NTOK,ITOK,CVALUE,ITYP,FVALUE) GOTO 10 ELSEIF(KEY.EQ.'FREE') THEN C C---Alternative flag for free reflections. Default is 0 IF(NTOK.LT.2) THEN LFreeRexcludeVal = 0 GOTO 10 ENDIF CALL GTNINT(2,1,LFreeRexcludeVal,NTOK,ITYP,FVALUE) GOTO 10 ELSEIF (KEY.EQ.'MAPC') THEN IF(NTOK.LT.2) GOTO 10 ITK = 2 IF(CVALUE(ITK).EQ.'FREE') THEN ITK = ITK + 1 IF(NTOK.LT.ITK) GOTO 10 IF(CVALUE(ITK).EQ.'INCL') THEN FREE_FOR_MAP = 'I' ELSE IF(CVALUE(ITK).EQ.'EXCL') THEN FREE_FOR_MAP = 'E' ELSEIF(CVALUE(ITK).EQ.'REST') THEN FREE_FOR_MAP = 'R' ENDIF else if(CVALUE(ITK).eq.'COEF') THEN itk = itk + 1 if(itk.le.NTOK) then CALL GTNREA(itk,1,scale_map_obs,NTOK,ITYP,FVALUE) itk = itk + 1 if(itk.le.ntok) then CALL GTNREA(itk,1,scale_map_calc,NTOK,ITYP,FVALUE) endif endif ENDIF GOTO 10 ELSEIF(KEY.EQ.'SET') THEN c---Should be added. Setting of some parameters like tolerances and C---so on CALL ERRWRT(0,'This part of the program is not ready') GOTO 10 ELSEIF(KEY.EQ.'NCYC') THEN C C---Number of refinement cycles. Default 5. IF(NTOK.LT.2) THEN NCCREF = 5 GOTO 10 ENDIF CALL GTNINT(2,1,NCCREF,NTOK,ITYP,FVALUE) GOTO 10 ELSEIF(KEY.EQ.'ANOM') THEN c c----Using anomalous scattering CALL ERRWRT(0,'This part of the program is not ready') GOTO 10 ELSEIF(KEY.EQ.'SYMM') THEN C C---Read symmetry and process it ITOK = 2 CALL READ_SYMM_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP, & FVALUE) GOTO 10 ELSEIF(KEY.EQ.'MONI') THEN c c---For monitoring some statistic ITOK = 2 IERROR = 0 CALL MONITOR_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP,FVALUE,CVALUE, & IERROR) NERROR = NERROR + IERROR GOTO 10 ELSEIF(KEY.EQ.'CELL') THEN C C---Read cell parameters. Usually should not be used. In some C---cases could be useful. It has highes priority. ITOK = 2 CALL RDCELL(ITOK,ITYP,FVALUE,NTOK,CELL) GOTO 10 ELSEIF(KEY.EQ.'WRIT') THEN DO ITK =2,NTOK IF(CVALUE(ITK).EQ.'MASK') THEN SOLVENT_WRITE_FLAG = .TRUE. ENDIF ENDDO GOTO 10 ELSEIF(KEY.EQ.'SHAN') THEN C c----Read shannon factor for grid spacing. Fshann is factor by which C----Niquist spacing is increased. Default is 1.3 FSHANN = 1.5 IF(NTOK.GE.2) THEN CALL GTNREA(2,1,FSHANN,NTOK,ITYP,FVALUE) IF(FSHANN.LE.0.0) THEN FSHANN = 1.5 ELSEIF(FSHANN.LE.1.0) THEN FSHANN = 1.0/FSHANN ENDIF ENDIF GOTO 10 ELSEIF(KEY.EQ.'SOLV') THEN CALL SOLVENT_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP,FVALUE,CVALUE, & IERROR) GOTO 10 ELSEIF(KEY.EQ.'RESO') THEN ITOK = 2 CALL RDRESO(ITOK,ITYP,FVALUE,NTOK,ResMin,ResMax,STLMIN,STLMAX) SMN = STLMIN STLMIN = SQRT(STLMIN)/2.0 STLMAX = SQRT(STLMAX)/2.0 ITK = 2 GOTO 10 ELSEIF (KEY.EQ.'RANG' .OR. KEY.EQ.'BINS') THEN NBIN = 20 IF (NTOK.GT.1) THEN C ************************************ CALL GTNREA(2,1,RANGE,NTOK,ITYP,FVALUE) C If range > 1 this gives the number of bins IF (RANGE .GT. 1.0) THEN NBIN = MIN(NBM-1,NINT(RANGE)) RANGE = -1 ENDIF END IF GO TO 10 ELSEIF(KEY.EQ.'WEIG') THEN C C---Weighting scheme. ITOK = 2 CALL WEIGHT_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP,FVALUE,CVALUE, & IERROR) GOTO 10 ELSEIF(KEY.EQ.'DAMP') THEN DAMP_FLAG = .TRUE. IF(NTOK.GE.2) CALL GTNREA(2,1,PDAMP,NTOK,ITYP,FVALUE) IF(NTOK.GE.3) CALL GTNREA(3,1,BDAMP,NTOK,ITYP,FVALUE) IF(NTOK.GE.4) CALL GTNREA(4,1,QDAMP,NTOK,ITYP,FVALUE) GOTO 10 ELSEIF(KEY.EQ.'DIST') THEN C C----Distance restrants IF(NTOK.GE.2) CALL GTNREA(2,1,WDSKAL,NTOK,ITYP,FVALUE) GOTO 10 ELSEIF(KEY.EQ.'ANGL') THEN C C----Bond angle restrants IF(NTOK.GE.2) CALL GTNREA(2,1,WASKAL,NTOK,ITYP,FVALUE) GOTO 10 C C=========================================================== ELSEIF(KEY.EQ.'TORS') THEN C C----Torsion restrants IF(NTOK.GE.2) CALL GTNREA(2,1,WTSKAL,NTOK,ITYP,FVALUE) GOTO 10 C C=========================================================== ELSEIF(KEY.EQ.'BFAC'.OR.KEY.EQ.'TEMP') THEN c c---Restraint on B-factors ITOK = 2 CALL READ_BFAC_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP,FVALUE, & CVALUE,IERROR) GOTO 10 ELSEIF(KEY.EQ.'OCCU') THEN ITOK = 2 CALL READ_OCCUP_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP,FVALUE, & CVALUE,IERROR) GOTO 10 ELSEIF(KEY.EQ.'SPHE') THEN C C----Restraint for sphericity of anisotropic U values IF(NTOK.GE.2) CALL GTNREA(2,1,SIGSPH,NTOK,ITYP,FVALUE) GOTO 10 C C=========================================================== ELSEIF(KEY.EQ.'RBON') THEN C C----Restraint on rigid bond IF(NTOK.GE.2) CALL GTNREA(2,1,SIG_RIGID_B,NTOK,ITYP,FVALUE) GOTO 10 ELSEIF(KEY.EQ.'PLAN') THEN c c---Restraints on planes and so on IF(NTOK.GE.2) CALL GTNREA(2,1,WPSKAL,NTOK,ITYP,FVALUE) GOTO 10 C C=========================================================== ELSEIF(KEY.EQ.'CHIR') THEN IF(NTOK.GE.2) CALL GTNREA(2,1,WCSKAL,NTOK,ITYP,FVALUE) GOTO 10 C C=========================================================== ELSEIF(KEY.EQ.'VDWR'.OR.KEY.EQ.'VAND'.OR.KEY.EQ.'NONB') THEN ITOK = 2 CALL READ_NBOND_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP,FVALUE, & CVALUE,IERROR) GOTO 10 ELSEIF(KEY.EQ.'REST') THEN ITOK = 2 CALL READ_RESTR_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP,FVALUE, & CVALUE,IERROR) GOTO 10 ELSEIF(KEY.EQ.'BLIM') THEN IF(NTOK.GE.2) THEN CALL GTNREA(2,1,BResetMin,NTOK,ITYP,FVALUE) BResetMin = BResetMin/PISQ8 ENDIF IF(NTOK.GE.3) THEN CALL GTNREA(3,1,BResetMax,NTOK,ITYP,FVALUE) BResetMax = BResetMax/PISQ8 ENDIF GOTO 10 ELSEIF(KEY.EQ.'NCSR'.OR.KEY.EQ.'NONX') THEN C C----Non cryst symmetry restraints ITOK = 2 CALL NCSR_PARAMS(NTOK,ITOK,IBEG,IEND,ITYP,FVALUE,CVALUE,IERROR) NERROR = NERROR + IERROR GOTO 10 ELSEIF(KEY.EQ.'NCSC') THEN C C---Non cryst symmetry constraints ITOK = 2 CALL NCSC_PARAMS(NTOK,ITOK,IBEG,IEND,ITYP,FVALUE,CVALUE,IERROR) NERROR = NERROR + IERROR GOTO 10 ELSEIF(KEY.EQ.'HOLD') THEN C C---This value can make refinement stable but slow. See document IF(NTOK.GE.2) CALL GTNREA(2,1,PDEL,NTOK,ITYP,FVALUE) IF(NTOK.GE.3) CALL GTNREA(3,1,BDEL,NTOK,ITYP,FVALUE) BDEL = BDEL/PISQ8 IF(NTOK.GE.4) CALL GTNREA(4,1,QDEL,NTOK,ITYP,FVALUE) GOTO 10 C C---Radius of sphere of confidence (max step size) ELSEIF(KEY.EQ.'RADI') THEN IF(NTOK.GE.2) CALL GTNREA(2,1,PRADIUS,NTOK,ITYP,FVALUE) IF(NTOK.GE.3) CALL GTNREA(3,1,BRADIUS,NTOK,ITYP,FVALUE) IF(NTOK.GE.4) CALL GTNREA(4,1,QRADIUS,NTOK,ITYP,FVALUE) GOTO 10 C ELSEIF(KEY.EQ.'SCAL') THEN c C---Read parameters for scaling ITOK = 2 CALL SCALE_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP,FVALUE,CVALUE, & IERROR) GOTO 10 ELSEIF(KEY.EQ.'SCPA') THEN C ITOK = 2 IF(NTOK.LT.2) GOTO 10 DO ITOK=2,NTOK C Scale these PARTial contributions independently of FC CALL GTNINT(ITOK,1,NSCLSEP,NTOK,ITYP,FVALUE) IF(NSCLSEP.GT.NMAXPART) + CALL ERRWRT(-1,' Only 9 FPART terms allowed') IF(NSCLSEP.GT.NMAXPART) NERROR = NERROR + 1 ISCPART(NSCLSEP) = 1 ENDDO GOTO 10 ELSEIF(KEY.EQ.'SOLV') THEN c c----Bulk solvent modelling. It is not clear how to do this CALL ERRWRT(0,'SOLVENT - This part of program is not ready') GOTO 10 ELSEIF(KEY.EQ.'MAKE') THEN c C---Read parameters for makeicf which makes restraints ITOK = 2 CALL MAKE_REST_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP,FVALUE, & CVALUE,IERROR) GOTO 10 ELSEIF(KEY.EQ.'LABI') THEN C C---Save line for further treatment.. Input mtz labels LABIN_SAVE = LINE GOTO 10 ELSEIF(KEY.EQ.'LABO') THEN c c---Output mtz labels. Save line for further treatment. LABOUT_SAVE = LINE GOTO 10 ELSEIF(KEY.EQ.'REFI') THEN C C---Read parameters for refinement. ITOK = 2 IERROR = 0 CALL REFI_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP,FVALUE, & CVALUE,IERROR) GOTO 10 ELSEIF(KEY.EQ.'RIGI') THEN C C---Read rigid body parameters ITOK = 1 CALL READ_RBODY_PARS(NERROR,NTOK,ITOK,CVALUE,ITYP,FVALUE) GOTO 10 C C---Hydrogens ELSEIF(KEY.EQ.'HYDR') THEN ITOK = 1 CALL READ_HYDROGEN_PARS(NTOK,ITOK,LINE,IBEG,IEND,ITYP,FVALUE, & CVALUE,IERROR) GOTO 10 ELSEIF(KEY.EQ.'TLSC') THEN C C---Number of cycles of TLS refinement. Implies MODE is 'TLSR'. MODE = 'TLSR' REFID = 'UNRE' IF(NTOK.GE.2) CALL GTNINT(2,1,NTLS_CYCLE,NTOK,ITYP,FVALUE) GOTO 10 ELSEIF(KEY.EQ.'END') THEN C ICONTINUE = 0 GOTO 999 ELSEIF(KEY.EQ.'QUIT'.OR.KEY.EQ.'STOP') THEN C ICONTINUE = -1 GOTO 999 ELSEIF(KEY.EQ.'GO') THEN C C----If icontinue = 1 program will come back to this subroutine again C---- after perfomring given instructions C---- icontinue = 0 program will finish its work after performing C---- given instructions C---- -1 no instructions will be perfomed. C C ICONTINUE = 1 GOTO 999 ELSE NUNREC = NUNREC + 1 IF(NUNREC.GT.50)CALL ERRWRT(1,' It is not command file') CALL ERRWRT(0,'Unrecognized keyword: '//KEY) GOTO 10 ENDIF c c----Normal return from subroutine RCARD. 999 CONTINUE IF(LABIN_SAVE.NE.' '.OR.LABOUT_SAVE.NE.' '.AND. & (REFID.NE.'IDEA'.OR.MODE.NE.'HKRF')) THEN IERROR = 0 CALL MTZ_PARAMS(LABIN_SAVE,LABOUT_SAVE,IERROR) NERROR = NERROR + IERROR ENDIF CALL CHECK_ALL_PARAMS(IERROR) NERROR = NERROR + IERROR IF( NERROR .GT.50 ) & CALL ERRWRT(1,' Too many errors in input cards - '// & 'check messages above.') CALL REPORT_OPTIONS cd CALL ERRWRT(1,'end of card') RETURN END c SUBROUTINE CHECK_ALL_PARAMS(IERROR) C C---checks all input parameters and tries to make them consistent and c---conflict free IMPLICIT NONE INTEGER IERROR INCLUDE 'refi_flags.fh' INCLUDE 'celsym.fh' INCLUDE 'agreem.fh' INCLUDE 'weights.fh' INCLUDE 'vitals.fh' INCLUDE 'rigid_body.fh' INCLUDE 'atom_com.fh' INCLUDE 'tls.fh' INCLUDE 'makecif.fh' CHARACTER FILE_NAME_HERE*256 REAL RSSCMN,RSSCMX INTEGER IP,II,HMAX,KMAX,LMAX,L_F INTEGER LENSTR LOGICAL ERROR,LEXISTS EXTERNAL LENSTR C C---Change mode and REFID to make consistent with further works IERROR = 0 IF(REFID.EQ.'RIGI') MODE = 'RIGI' IF(REFID.EQ.'TLSR') MODE = 'TLSR' IF(MODE.EQ.'TLSR'.AND.NTLS_CYCLE.LE.0) NTLS_CYCLE = 20 IF(MODE.EQ.'RIGI') REFID = 'UNRE' IF(MODE.EQ.'TLSR') REFID = 'UNRE' IF(MODE.EQ.'NEWE') THEN REFID = 'IDEA' MAKE_HFLAG_O = 'Y' ENDIF IF(REFID.EQ.'IDEA') THEN REFUSE = .FALSE. cd IF(MAKE_CHECK.NE.'Y') MAKE_CHECK = '0' ENDIF IF(WEIGHT.EQ.' ') WEIGHT = 'MATR' cd IF(REFID.EQ.'UNRE') ITEMP = 0 c c---If maximum likelihood then use normalisation. IF(REFS.EQ.'MLKF') THEN LNORMAL = .TRUE. NRESIOPT = 1 NSIGOPT = 1 ENDIF c c---Estimate maximum number of possible reflections. This estimate gives C---upper limit. IF(REFUSE) THEN C Find a reasonable upper limit for number of reflections to include. REsmin = 0.5/STLMIN REsmax = 0.5/STLMAX HMAX = INT(CELL(1)/RESMAX) KMAX = INT(CELL(2)/RESMAX) LMAX = INT(CELL(3)/RESMAX) C SZ = INT(1.2*(2+HMAX)*(2+KMAX)*(2+LMAX)*2*3.20/(3*NSYM)) CALL FIND_CENTR_SYM(NumSymmetry,MaxSym,RealSymmMatrx, + IFACTOR_CC,ERROR) NOBS = IFACTOR_CC* + INT(1.2*(1.0+REAL(HMAX))*(1.0+REAL(KMAX))* * (1.0+REAL(LMAX))*2*3.20/(3.0*REAL(NSYM))) ENDIF C c---find number of partial structures NSCPART = 0 IF(FPART_FLAG) THEN DO IP=1,NMAXPART IF(ISCPART(IP).EQ.1) NSCPART = NSCPART + 1 ENDDO ENDIF C RSSCMN = 0.5/SMINS RSSCMX = 0.5/SMAXS C----Change default damping factor if they have not been set specifacly IF(.NOT.DAMP_FLAG) THEN C C----Change damping factors if resolution is less than 2.5 cd IF( RSSCMX .GT. 2.5) THEN cd PDAMP = 0.5 cd BDAMP = 0.5 cd ENDIF C C----Change damping factor for unrestrained but not rigid body refinement cd IF(REFID.EQ.'UNRE'.AND.MODE.NE.'RIGI') THEN cd PDAMP = 0.3 cd BDAMP = 0.3 cd ENDIF END IF C NDOMAIN = 0 DO II=1,MAXDOMAIN IF(IDOMAIN_PIECES(II).GT.0) NDOMAIN = NDOMAIN+1 ENDDO C C----NCS restraints here C C---Tls parameters should be read if number of cycles has not been defined TLS_FILE_FLAG = .FALSE. IF(NTLS_CYCLE.GT.0) THEN TLS_FILE_FLAG = .TRUE. ELSE CALL UGTENV('TLSIN',FILE_NAME_HERE) L_F = LENSTR(FILE_NAME_HERE) IF(L_F.LE.0) THEN TLS_FILE_FLAG = .FALSE. ELSE IF(FILE_NAME_HERE(1:L_F).NE.'TLSIN') THEN INQUIRE(FILE=FILE_NAME_HERE(1:L_F),EXIST=LEXISTS) IF(LEXISTS) TLS_FILE_FLAG = .TRUE. ENDIF ENDIF ENDIF C RETURN END C SUBROUTINE DEFLTS c c---Subroutine ofr assigning default values for some parameters of refinement INCLUDE 'atom_com.fh' INCLUDE 'agreem.fh' INCLUDE 'celsym.fh' INCLUDE 'monitor.fh' INCLUDE 'pls_incl.fh' INCLUDE 'refi_flags.fh' INCLUDE 'vitals.fh' INCLUDE 'weights.fh' INCLUDE 'const.fh' INCLUDE 'cif_incl.fh' INCLUDE 'rigid_body.fh' INCLUDE 'tls.fh' INCLUDE 'makecif.fh' INCLUDE 'ncs_rest.fh' INCLUDE 'solvent.fh' INCLUDE 'restr_files.fh' INCLUDE 'expcost.fh' INCLUDE 'occupancy_params.fh' INCLUDE 'restr_params.fh' INCLUDE 'map_params.fh' C COMMON /FILES / ISYSR,ISYSW,IFOFC,ISCRF,IATMR,IDISK,JDISK,NEWFIL . ,INXYZ,IOUTX,MTZIN C C Clear agreem.fh arrays DATA AFOMFC/NBM2*0/,AFO/NBM2*0/,AFC/NBM2*0/,AFOFO/NBM2*0/, + AFCFC/NBM2*0/,WFOMFC/NBM2*0/,ASIG/NBM2*0/,AWGT/NBM2*0/, + AFOFC/NBM2*0/,WFO/NBM2*0/,WFOFO/NBM2*0/,RFAC/NBM2*0/, + WRFC/NBM2*0/,CORR/NBM2*0/,SIGE/NBM2*0/ C DATA FOMAVA/NBM2*0/,FOMOVERA/2*0/ C DATA FOMAVC/NBM2*0/,FOMOVERC/2*0/ DATA FOMAVT/NBM2*0/,FOMOVERT/2*0/ DATA NREFA/NBM2*0/,NREFC/NBM2*0/,NREFOVERA/2*0/, + NREFOVERC/2*0/,NREFOVERT/2*0/ C C Clear celsym.fh arrays DATA CELL/6*0/,ROR/9*0/,RFR/9*0/ DATA ROT/MAXSYM9*0/,TR/MAXSYM3*0/,ROTR/MAXSYM9*0/ C C----Constants DATA EPSCH1/0.1/,EPSCOMP/1.0E-32/,FTOL/1.0E-8/,GOLD/1.618034/, + CGOLD/0.3819660/,ZEPS/1.0E-10/,TOL/1.0E-8/ C C---Constants. Double precision PID = ATAN2(1.0,1.0)*4.0 PIDSQ = PID*PID PIDSQ4 = PIDSQ*4.0 PIDSQ8 = PIDSQ*8.0 TWOPID = PID*2.0 FOURPID = PID*4.0 C C---Constants. Single precision PI = ATAN2(1.0,1.0)*4.0 PISQ = PI*PI PISQ4 = PISQ*4.0 PISQ8 = PISQ*8.0 TWOPI = PI*2.0 FOURPI = PI*4.0 RTODEG = 180.0/PI DEGTOR = PI/180.0 C C---Shannon factor. I.e. how much more grid extra spacing is needed. C---1.3 means 50% more than Niquist spacing FSHANN = 1.4 C C----Default refinement type REFUSE = .TRUE. CRDUSE = .TRUE. REFTYP = 'MTZ ' CRDTYP = 'PDB ' C C---Radii for modelling of atomic density for electron density C---gradient and second derivative calculations DDLIM = 5.0 DGLIM = 5.0 DHLIM = 8.0 C C Default P1 symmetry LTYPE = 'P' SpaceGroupName = 'P1' PointGroupName = 'PG1' ISPNO = 0 NumSpaceGroup = 1 NSYM = 1 NPSYM = 1 NumSymmetry = 1 NumPrimSymm = 1 DO I=1,3 DO J=1,3 ROT(I,J,1) = 0.0 RealSymmMatrx(I,J,1) = 0.0 RealSYMMRFT(I,J,1) = 0.0 RecipSymmMatrx(I,J,1) = 0.0 ENDDO ROT(I,I,1) = 1.0 RealSymmMatrx(I,I,1) = 1.0 RealSYMMRFT(I,I,1) = 1.0 RecipSymmMatrx(I,I,1) = 1.0 C RecipSymmMatrx(I,4,1) = 0.0 RealSymmMatrx(I,4,1) = 0.0 RealSYMMRFT(I,4,1) = 0.0 RecipSymmMatrx(4,I,1) = 0.0 RealSymmMatrx(4,I,1) = 0.0 RealSYMMRFT(4,I,1) = 0.0 TR(I,1) = 0.0 ENDDO NX = 0 NY = 0 NZ = 0 C C C----Default sort order for HKLOUT ISORT(1) = 1 ISORT(2) = 2 ISORT(3) = 3 ISORT(4) = 0 ISORT(5) = 0 c c-----Mode of action MODE = 'HKRF' ITEMP = 1 NANISO_ATOMS = 0 C c--Convergence EPS_CONV_X = 0.000001 EPS_CONV_B = 0.000001 C c--Shifts DAMP_FLAG = .FALSE. PDAMP = 1.0 BDAMP = 1.0 QDAMP = 1.0 BResetMin = 2.0/PISQ8 BResetMax = 500.0/PISQ8 BSET_DEFAULT_FLAG = .FALSE. UDefault_Ind = 0.25 C C------Number of cycles and so on NCYCCG = 50 NCYCLE_OVERALL = 0 NCCREF = 5 NONSYM = 2 C C---Refinement style REFID = 'REST' IANISB = 0 NBIN = 20 RANGE = -1.0 c c---Monitoring MON_STYLE = 'MEDI' TORCUT = 10.0 CHICUT = 10.0 DSCUT = 10.0 ANGLCUT = 10.0 PLCUT = 10.0 BADVDW = 10.0 BFAC_CUT = 10.0 RBON_CUT = 10.0 BSPH_CUT = 10.0 NCSR_CUT = 20.0 BAD_CONT = 1.0 C C---Weights for structure factor terms KFWGT = 1 WEIGHT = ' ' WEIGHTXMAT = 0.5 C C---Weights for torsion angles WTSKAL = 1.00 SIGT(1) = 15.0 SIGT(2) = 5.0 SIGT(3) = 10.00 SIGT(4) = 20.00 C C---Weights for distances WDSKAL = 1.00 SIGD(1) = 0.02 SIGD(2) = 0.04 SIGD(3) = 0.05 SIGD(4) = 0.050 SIGD(5) = 0.020 SIGD(6) = 0.020 SIGD(7) = 0.020 C c---Weight for angle restraints WASKAL = 1.0 C c----Weights for b-factors WBSKAL = 1.00 SIGB(1) = 1.50 SIGB(2) = 2.00 SIGB(3) = 3.00 SIGB(4) = 4.50 SIGB(5) = 6.000 SIGB(6) = 2.0 SIGB(7) = 2.00 SIGB(8) = 0.00 C C---Some other default restraint parameters C NCIS_TRANS_RES = 0 NCHIR_REPLACE = 0 C C---Weights for sphericity of aniso U values SIGSPH = 3.0 C C---Weights on rigid bond SIG_RIGID_B = 3.0 WBS_RIGID_B = 1.0 C C---Weights for Planes WPSKAL = 1.00 C C---Weights for Chirality WCSKAL = 1.00 C C---Weights for Vdw WVSKAL = 1.00 VDW_SDI_VDW = 0.2 VDW_SDI_TORSION = 0.2 VDW_SDI_HBOND = 0.2 VDW_SDI_METAL = 0.2 HBOND_DINC_AD = -0.3 HBOND_DINC_AH = 0.1 DINC_TORSION = -0.3 DINC_TORSION_O = -0.1 DINC_TORSION_N = -0.1 DINC_TORSION_C = -0.15 DINC_TORSION_ALL= -0.15 DINC_DUMMY = -0.7 VDW_SDI_DUMMY = 0.3 DVDW_CUT_MIN = 1.75 DVDW_CUT_MIN_X = 1.75 C C---Weight on positions PDEL = 0.00 BDEL = 0.000 QDEL = 0.000 CCB*radius of confidence PRADIUS = 0.3 BRADIUS = 0.03 QRADIUS = 0.5 C C---Weights for NCS WSSKAL = 1.000 SIGS(1) = 0.050 SIGS(2) = 0.500 SIGS(3) = 5.000 SIGS(4) = 0.500 SIGS(5) = 2.000 SIGS(6) = 10.000 C C---Some more restraint info. Info for restrainable torsions N_RESTRAIN_TORS = 10 RES_NAME_TORS_RESTR(1) = '.' GROUP_NAME_TORS_RESTR(1) = 'L-peptide' LINK_NAME_TORS_RESTR(1) = '.' RES_NAME_TORS_NAME(1) = 'chi1' RES_NAME_TORS_PERIOD(1) = -1 RES_NAME_TORS_VALUE(1) = -1.0E32 RES_NAME_TORS_SIGMA(1) = -0.1 RES_NAME_TORS_RESTR(2) = '.' GROUP_NAME_TORS_RESTR(2) = 'L-peptide' LINK_NAME_TORS_RESTR(2) = '.' RES_NAME_TORS_NAME(2) = 'chi2' RES_NAME_TORS_PERIOD(2) = -1 RES_NAME_TORS_VALUE(2) = -1.0E32 RES_NAME_TORS_SIGMA(2) = -0.1 RES_NAME_TORS_RESTR(3) = '.' GROUP_NAME_TORS_RESTR(3) = 'L-peptide' LINK_NAME_TORS_RESTR(3) = '.' RES_NAME_TORS_NAME(3) = 'chi3' RES_NAME_TORS_PERIOD(3) = -1 RES_NAME_TORS_VALUE(3) = -1.0E32 RES_NAME_TORS_SIGMA(3) = -0.1 RES_NAME_TORS_RESTR(4) = '.' GROUP_NAME_TORS_RESTR(4) = 'L-peptide' LINK_NAME_TORS_RESTR(4) = '.' RES_NAME_TORS_NAME(4) = 'chi' RES_NAME_TORS_PERIOD(4) = -1 RES_NAME_TORS_VALUE(4) = -1.0E32 RES_NAME_TORS_SIGMA(4) = -0.1 RES_NAME_TORS_RESTR(5) = '.' GROUP_NAME_TORS_RESTR(5) = 'L-peptide' LINK_NAME_TORS_RESTR(5) = '.' RES_NAME_TORS_NAME(5) = 'chi4' RES_NAME_TORS_PERIOD(5) = -1 RES_NAME_TORS_VALUE(5) = -1.0E32 RES_NAME_TORS_SIGMA(5) = -0.1 RES_NAME_TORS_RESTR(6) = '.' GROUP_NAME_TORS_RESTR(6) = 'L-peptide' LINK_NAME_TORS_RESTR(6) = '.' RES_NAME_TORS_NAME(6) = 'chi5' RES_NAME_TORS_PERIOD(6) = -1 RES_NAME_TORS_VALUE(6) = -1.0E32 RES_NAME_TORS_SIGMA(6) = -0.1 RES_NAME_TORS_RESTR(7) = '.' GROUP_NAME_TORS_RESTR(7) = '.' LINK_NAME_TORS_RESTR(7) = 'TRANS' RES_NAME_TORS_NAME(7) = 'omega' RES_NAME_TORS_PERIOD(7) = -1 RES_NAME_TORS_VALUE(7) = -1.0E32 RES_NAME_TORS_SIGMA(7) = -0.1 RES_NAME_TORS_RESTR(8) = '.' GROUP_NAME_TORS_RESTR(8) = '.' LINK_NAME_TORS_RESTR(8) = 'PTRANS' RES_NAME_TORS_NAME(8) = 'omega' RES_NAME_TORS_PERIOD(8) = -1 RES_NAME_TORS_VALUE(8) = -1.0E32 RES_NAME_TORS_SIGMA(8) = -0.1 RES_NAME_TORS_RESTR(9) = '.' GROUP_NAME_TORS_RESTR(9) = '.' LINK_NAME_TORS_RESTR(9) = 'CIS' RES_NAME_TORS_NAME(9) = 'omega' RES_NAME_TORS_PERIOD(9) = -1 RES_NAME_TORS_VALUE(9) = -1.0E32 RES_NAME_TORS_SIGMA(9) = -0.1 RES_NAME_TORS_RESTR(10) = '.' GROUP_NAME_TORS_RESTR(10) = '.' LINK_NAME_TORS_RESTR(10) = 'PCIS' RES_NAME_TORS_NAME(10) = 'omega' RES_NAME_TORS_PERIOD(10) = -1 RES_NAME_TORS_VALUE(10) = -1.0E32 RES_NAME_TORS_SIGMA(10) = -0.1 DO I=11,NMAX_RESTRAIN_TORS RES_NAME_TORS_RESTR(I) = '.' GROUP_NAME_TORS_RESTR(I) = '.' RES_NAME_TORS_NAME(I) = '.' RES_NAME_TORS_PERIOD(I) = -1 RES_NAME_TORS_VALUE(I) = -0.1 RES_NAME_TORS_SIGMA(I) = -0.1 ENDDO C N_RESTRAIN_TORS_E = 3 RES_NAME_TORS_RESTR_E(1) = 'PRO' GROUP_NAME_TORS_RESTR_E(1) = '.' LINK_NAME_TORS_RESTR_E(1) = '.' RES_NAME_TORS_NAME_E(1) = 'chi1' RES_NAME_TORS_RESTR_E(2) = 'PRO' GROUP_NAME_TORS_RESTR_E(2) = '.' LINK_NAME_TORS_RESTR_E(2) = '.' RES_NAME_TORS_NAME_E(2) = 'chi2' RES_NAME_TORS_RESTR_E(3) = 'PRO' GROUP_NAME_TORS_RESTR_E(3) = '.' LINK_NAME_TORS_RESTR_E(3) = '.' RES_NAME_TORS_NAME_E(3) = 'chi3' C C---Exclude some residues (PRO) from the restraint list. C C--- C NUMBER_NCSR = 0 NUMBER_NCSC = 0 c c----Solvent structure SOLVENT_FLAG = .TRUE. SOLVENT_WRITE_FLAG = .FALSE. B_LS_SOLVENT_MASK_FLAG = .TRUE. SCALE_LS_SOLVENT_MASK_FLAG = .TRUE. PROB_VDW = 1.2 PROB_ION = 0.8 RADII_SHRINK = 0.8 SCALE_LS_SOL_M = 0.35 B_LS_SOL_M = 70.0 C C---CIF CIFOUT = 'NONE' C C---Channel numbers ISYSR = 5 ISYSW = 6 IFOFC = 0 IATMR = 0 Cejd - IDISK not used ICNTS not set - change ICNTS to IDISK? IDISK = 0 JDISK = 0 NEWFIL= 0 INXYZ = 0 IOUTX = 0 ISCRF = 0 MTZIN = 1 C C---LS scaling. Set initial values and flags for scale parameters SCALE_LS_OVER = 1.0 B_LS_OVER = 0.0 B_LS_OVER_FLAG = .TRUE. B_LS_OVER_REFINE_FLAG = .TRUE. ALL_SCALES_FLAG = .TRUE. LS_SCALE_FLAG = .TRUE. ML_SCALE_FLAG = .TRUE. DO IAN=1,6 B_LS_ANISO_OVER(IAN) = 0.0 ENDDO DO IAN=1,6 DO IAN1 = 1,6 EIGEN_ANISO(IAN,IAN1) = 0.0 IF(IAN.EQ.IAN1) EIGEN_ANISO(IAN,IAN) = 1.0 ENDDO ENDDO B_LS_ANISO_OVER_FLAG = .TRUE. B_LS_ANISO_OVER_REFINE_FLAG = .TRUE. BULK_LS_FLAG = .FALSE. B_LS_BULK_REFINE_FLAG = .TRUE. B_LS_BULK = 200.0 SCALE_LS_BULK_REFINE_FLAG = .TRUE. SCALE_LS_BULK = 0.75 DO IP=1,NMAXPART B_LS_PART_REFINE_FLAG(IP) = .TRUE. B_LS_PART(IP) = 100.0 SCALE_LS_PART_REFINE_FLAG(IP) = .TRUE. SCALE_LS_PART(IP) = 0.33 ENDDO C BINSCALE = 0 NGRCYCL = 5 NPARCYCL = 4 C C---ML scale parameters D_ML_SCALE_OVER = 1.0 D_ML_B_OVER = 0.0 D_ML_SCALE_BBULK = 0.0 D_ML_B_BBULK = 100.0 ML_BULK_REFINE_FLAG = .TRUE. DO I=1,NMAXPART D_ML_SCALE_PART(I) = 1.0 D_ML_B_PART(I) = 70.0 ML_PART_REFINE_FLAG(I) = .TRUE. ENDDO SIGMA_ML_SCALE_OVER = 1.0 SIGMA_ML_B_OVER = 40.0 SIGMA_ML_SCALE_BBULK = 0.4 SIGMA_ML_B_BBULK = 100.0 ML_SIGMA_BULK_REFINE_FLAG = .TRUE. C Set ISCPART(i) = 0; ie Add all partial terms to FC before scaling DO I = 1,NMAXPART ISCPART(I) = 0 ENDDO C Set free R exclusion flag LFreeRexcludeVal = -999 C C----Default refinement flags XNONDIAG_FLAG = .TRUE. OCCUP_REF_FLAG = .FALSE. POS_REF_FLAG = .TRUE. EXCLUDE_OCC_B = .TRUE. NCYCLE_OCC = 2 DIS_FLAG = .TRUE. ANGL_FLAG = .TRUE. PLANE_FLAG = .TRUE. VDW_FLAG = .TRUE. TOR_FLAG = .TRUE. SYM_FLAG = .TRUE. CHI_FLAG = .TRUE. B_FLAG1 = .TRUE. GRADC = .TRUE. HCALC = .TRUE. FREER_FLAG = .FALSE. FPART_FLAG = .FALSE. MIR_FLAG = .FALSE. PHASE_FLAG = .FALSE. PHASE_SIGMAA_FLAG = .FALSE. PHAS_BLUR_SCAL = 1.0 PHAS_BLUR_BVAL = 0.0 NTRIGINC = 12 NINTEGRSTEP = 360 ARGMAX = 59.0 C LEXPUSE = .TRUE. LSEXPUSE = .FALSE. MLEXPUSE = .TRUE. C C---Residual is amplitude based LS LREFIN = .TRUE. REFS = 'MLKF' LNORMAL = .FALSE. NPART = 0 NPARTALL = 0 NSCPART = 0 NOBS = 0 LSTAT = .TRUE. LSUSEWORK = .TRUE. MLUSEWORK = .FALSE. LINIT = .FALSE. MLINIT = .FALSE. NLSCYCL = 10 NMLCYCL = 10 NRESIOPT = 1 NSCOPT = 1 NSIGOPT = 0 C C----Scling type. Aniso or iso IMLSCALTYPOV = 0 ILSSCALTYPOV = 0 MLSCALTYPE = 'ISOTR' LSSCALTYPE = 'ISOTR' DO I=1,NMAXPART IMLSCALTYP(I) = 0 ILSCALTYP(I) = 0 ENDDO DO I=1,NMAXPAR ILSFIX(I) = 0 IMLFIX(I) = 0 ENDDO LSSCFIX = .FALSE. LSBFIX = .FALSE. MLSCFIX = .FALSE. MLBFIX = .FALSE. BLS_DEFINED = 200.0 SCLS_DEFINED = -0.3 BML_DEFINED = 150.0 SCML_DEFINED = -0.3 BAVER_MOLEC = -100.0 UAVER_MOLEC = BAVER_MOLEC/PISQ8 C C---Minimization method SOLVMIN = 'CGMAT' c SOLVMIN = 'CGMA' NESTIM = 1 STLMIN = 0.0000001 STLMAX = 10.0 SMINS = 0.04 SMAXS = 1.0 C C--Aniso scaling. Apply to calculated (default) APPLY_SCALE_TO = 'CALC' C C---Rigid body defaults DO IDOMAIN=1,MAXDOMAIN IDOMAIN_PIECES(IDOMAIN) = 0 DO IPIECE=1,MAXPIECES IDOMAIN_CHN(IPIECE,IDOMAIN) = ' ' IDOMAIN_FROM(IPIECE,IDOMAIN) = -1 IDOMAIN_TO(IPIECE,IDOMAIN) = -1 ENDDO DO IX=1,3 TRANS_INIT_RIGID(IX,IDOMAIN) = 0.0 EULER_INIT_RIGID(IX,IDOMAIN) = 0.0 ENDDO EXCLUDE_DOMAIN(IDOMAIN) = 'NONE' ENDDO NDOMAIN = 1 NRIGID_CYCLE = 20 EULER_PRINT_RIGID = .TRUE. MATRIX_PRINT_RIGID = .TRUE. POLAR_PRINT_RIGID = .TRUE. C C---TLS defaults DO ITLSGRP=1,MAXTLSGRP ITLSGRP_PIECES(ITLSGRP) = 0 TLSGRP_TITLE(ITLSGRP) = 'From REFMAC' DO IPIECE=1,MAXPIECES_TLS TLSGRP_CHN(IPIECE,ITLSGRP) = ' ' ITLSGRP_FROM(IPIECE,ITLSGRP) = -1 ITLSGRP_TO(IPIECE,ITLSGRP) = -1 DO ISEL = 1,MAXSELECT TLSGRP_SELECT(ISEL,IPIECE,ITLSGRP) = ' ' ENDDO ENDDO ENDDO DO I=1,MAXTLSGRP20 SHFT_TLS(I)=0.0 ENDDO NTLSGRP = 0 NTLS_CYCLE = 0 PRINT_TLSPARS = .TRUE. TLS_FILE_FLAG = .FALSE. C C---Map parameters FREE_FOR_MAP = 'R' scale_map_calc = 0.0 scale_map_obs = 0.0 C C---Parameters for makecif MAKE_HFLAG = 'A' MAKE_HFLAG_O = 'N' MAKE_RFLAG = 'N' MAKE_LNK_FLAG = 'N' MAKE_CHECK_SPEC = 'N' MAKE_FORM = 'U' MAKE_PEPT_FLAG = 'N' MAKE_CONN_FLAG = 'N' MAKE_SYMM_FLAG = 'Y' MAKE_CHAIN_FLAG = 'N' MAKE_SS_FLAG = 'Y' MAKE_CIS_FLAG = 'Y' MAKE_SUGAR_FLAG = 'S' MAKE_EXIT = 'N' MAKE_CHECK = 'N' MAKE_LIGAND_LEVEL_FLAG = 'H' MAKE_NEWL_VALUE_FLAG = 'N' MAKE_NEW_FLAG = 'N' MAKE_SRCH_FLAG = 'N' MAKE_LIBS_PATH = ' ' MAKE_LIBS_NAME = ' ' MAKE_LIBS_EXT = ' ' MAKE_PROG_LIB_PATH = ' ' MAKE_OUT_FILE = ' ' MAKE_FILE_LIB2 = ' ' MAKE_CUTOFF = 0.0 MAKE_DMIN_SPEC = 0.3 C C---Hydrogen refinement parameters HYDROGEN_REFINE_FLAG = .FALSE. HYDROGEN_BVALUE = 'ANIS' C c---File names STRUCT_FILE = ' ' COORD_FILE = ' ' RESTRAINT_FILE = ' ' BOND_FILE = ' ' ANGLE_FILE = ' ' VDW_FILE = ' ' CHIR_FILE = ' ' TORS_FILE = ' ' NCSR_FILE_NAME = ' ' NCSC_FILE_NAME = ' ' PLANE_FILE = ' ' C c--exclusions excl_refi_flag = .FALSE. excl_refi_num = 0 RETURN END C SUBROUTINE TKNONCUB C C---Takes from symmetry operators noncubic ones and C---assigns to ROTR,TRR C--- INCLUDE 'celsym.fh' C NonCubSym = 0 Nsmult = NumSymmetry/NumPrimSymm DO IS=1,NumSymmetry IF(ABS(RealSymmMatrx(3,3,IS)).EQ.1.0 .AND. + RealSymmMatrx(3,1,IS).EQ.0.0 .AND. + RealSymmMatrx(3,2,IS).EQ.0.0) THEN NonCubSym = NonCubSym + 1 DO I=1,3 DO J=1,3 ROTR(I,J,NonCubSym) = RealSymmMatrx(I,J,IS) ENDDO TRR(I,NonCubSym) = RealSymmMatrx(I,4,IS) ENDDO ENDIF ENDDO NonCubPrim = NonCubSym/Nsmult RETURN END SUBROUTINE REPORT_OPTIONS C C---Reports current parameters of refinement C INCLUDE 'atom_com.fh' INCLUDE 'pls_incl.fh' INCLUDE 'refi_flags.fh' INCLUDE 'rigid_body.fh' INCLUDE 'celsym.fh' INCLUDE 'agreem.fh' INCLUDE 'cif_incl.fh' INCLUDE 'monitor.fh' INCLUDE 'vitals.fh' INCLUDE 'weights.fh' INCLUDE 'expcost.fh' INCLUDE 'const.fh' INCLUDE 'makecif.fh' INCLUDE 'ncs_rest.fh' INCLUDE 'solvent.fh' INTEGER HMAX,KMAX,LMAX COMMON /FILES / ISYSR,ISYSW,IFOFC,ISCRF,IATMR,IDISK,JDISK,NEWFIL . ,INXYZ,IOUTX,MTZIN REAL CELL_REPORT(6) INTEGER LENSTR EXTERNAL LENSTR LOGICAL ERROR,LEXISTS CHARACTER LINE*512,ALL_CHAINS*120,FILE_NAME_HERE*128, & DICT_PATH*250 cpjx Don't use temp_makecif_path.fh - it's not portable! cpjx INCLUDE 'temp_makecif_path.fh' C C--Start reporting C CALL HEADER('Input and Default parameters#') CALL ERRWRT(-1,' ') CALL UGTENV('XYZIN',FILE_NAME_HERE) IF(FILE_NAME_HERE(1:1).NE.' ') THEN WRITE(LINE,'(A)')'Input coordinate file. Logical name - XYZIN'// & ' actual file name - '//FILE_NAME_HERE(1:LENSTR(FILE_NAME_HERE)) ELSE WRITE(LINE,'(A)')'Input coordinate file. Logical name - XYZIN'// & ' actual file name - XYZIN' ENDIF CALL ERRWRT(-1,LINE) CALL UGTENV('XYZOUT',FILE_NAME_HERE) IF(FILE_NAME_HERE.EQ.' ') FILE_NAME_HERE = 'XYZOUT' WRITE(LINE,'(A)')'Output coordinate file. Logical name - XYZOUT'// & ' actual file name - '//FILE_NAME_HERE(1:LENSTR(FILE_NAME_HERE)) CALL ERRWRT(-1,LINE) IF(REFUSE) THEN CALL UGTENV('HKLIN',FILE_NAME_HERE) IF(FILE_NAME_HERE(1:1).NE.' ') THEN WRITE(LINE,'(A)') & 'Input reflection file. Logical name - HKLIN'// & ' actual file name - '//FILE_NAME_HERE(1:LENSTR(FILE_NAME_HERE)) ELSE WRITE(LINE,'(A)') '==> WARNING: No HKLIN has been defined' ENDIF CALL ERRWRT(-1,LINE) CALL UGTENV('HKLOUT',FILE_NAME_HERE) IF(FILE_NAME_HERE.EQ.' ') FILE_NAME_HERE = 'HKLOUT' WRITE(LINE,'(A)') & 'Output reflection file. Logical name - HKLOUT'// & ' actual file name - '//FILE_NAME_HERE(1:LENSTR(FILE_NAME_HERE)) CALL ERRWRT(-1,LINE) CELL_REPORT(1) = CELL(1) CELL_REPORT(2) = CELL(2) CELL_REPORT(3) = CELL(3) CELL_REPORT(4) = CELL(4) CELL_REPORT(5) = CELL(5) CELL_REPORT(6) = CELL(6) IF(CELL(4).LE.5.0.OR.CELL(5).LE.5.0 & .OR.CELL(6).LE.5.0) THEN CELL_REPORT(4) = CELL(4)/DEGTOR CELL_REPORT(5) = CELL(5)/DEGTOR CELL_REPORT(6) = CELL(6)/DEGTOR ENDIF CALL ERRWRT(-1,' ') WRITE(LINE,'(A,6F10.3)')'Cell from mtz :',CELL_REPORT CALL ERRWRT(-1,LINE) WRITE(LINE,'(A,I4,A,A)')'Space group from mtz:'// & ' number - ',NumSpaceGroup, & '; name - ',SpaceGroupName CALL ERRWRT(-1,LINE) ENDIF C C--Find file names and print them out. CALL ERRWRT(-1,' ') IF(REFID.EQ.'REST') WRITE(LINE,'(A)') + ' Refinement type : Restrained' IF(REFID.EQ.'UNRE') WRITE(LINE,'(A)') + ' Refinement type : Unrestrained' IF(REFID.EQ.'IDEA')THEN REFUSE = .FALSE. ITEMP = 0 WRITE(LINE,'(A)') + ' Refinement type : Idealisation' ENDIF IF(MODE.EQ.'RIGI') WRITE(LINE,'(A)') + ' Refinement type : Rigid Body' IF(MODE.EQ.'TLSR') WRITE(LINE,'(A)') + ' Refinement type : TLS' CALL ERRWRT(-1,LINE) CALL ERRWRT(-1,' ') C IF(BSET_DEFAULT_FLAG) THEN CALL ERRWRT(-1,' ') WRITE(LINE,'(A,F10.3)')'Initial B values of all atoms '// & 'will be set to ',UDefault_Ind*PISQ8 CALL ERRWRT(-1,LINE) CALL ERRWRT(-1,' ') ENDIF IF(REFID.NE.'UNRE') THEN C C--Makecif parameters CALL HEADER('Makecif parameters') CALL UGTENV('CLIBD_MON',DICT_PATH) IF(DICT_PATH.EQ.' ') CALL UGTENV('CDIC_REFMAC',DICT_PATH) IF(DICT_PATH.NE.' ') THEN INQUIRE (FILE=DICT_PATH(1:LENSTR(DICT_PATH))//'ener_lib.cif', & EXIST=LEXISTS) IF(.NOT.LEXISTS) THEN CALL ERRWRT(-1,' ') CALL ERRWRT(-1,'Dictionary path have not been defined') CALL ERRWRT(-1,'Check the environment variable CLIBD_MON') CALL ERRWRT(-1,'Current value of CLIBD_MON is '//DICT_PATH) CALL ERRWRT(-1,'It should be set to wherever_dict/dic/') CALL ERRWRT(1,'Wrong path for the dictionary files') ENDIF CALL ERRWRT(-1,'Dictionary files for restraints : '// & DICT_PATH(1:LENSTR(DICT_PATH))//'mon*cif') CALL ERRWRT(-1,'Parameters for new entry and VDW: '// & DICT_PATH(1:LENSTR(DICT_PATH))//'ener_lib.cif') ELSE cpjx MAKECIFLIB would be set in temp_makecif_path.fh cpjx but this is unsafe e.g. portability problems. cpjx CALL ERRWRT(-1,'Dictionary files for restraints : '// cpjx & MAKECIFLIB(1:LENSTR(MAKECIFLIB))//'mon*cif') cpjx CALL ERRWRT(-1,'Parameters for new entry and VDW: '// cpjx & MAKECIFLIB(1:LENSTR(MAKECIFLIB))//'ener_lib.cif') cpjx Fail if the dictionary path isn't set CALL CCPERR(1,'No path for dictionary files!') ENDIF C CALL UGTENV('LIBIN',MAKE_FILE_LIB2) IF(MAKE_FILE_LIB2.EQ.' ') CALL UGTENV('LIB_IN',MAKE_FILE_LIB2) IF(MAKE_FILE_LIB2.NE.' ') THEN C C---Check if it is a file INQUIRE (FILE=MAKE_FILE_LIB2(1:LENSTR(MAKE_FILE_LIB2)), & EXIST=LEXISTS) IF(LEXISTS) THEN CALL ERRWRT(-1,'User supplied dictionary entries: '// & MAKE_FILE_LIB2(1:LENSTR(MAKE_FILE_LIB2))) ELSE CALL ERRWRT(0, & 'LIBIN has been defined but it is not a file') MAKE_FILE_LIB2 = ' ' ENDIF ENDIF IF(MAKE_CHECK.EQ.'Y') THEN CALL ERRWRT(-1, & ' Program will check all entries against dictionary') ELSEIF(MAKE_CHECK.EQ.'0') THEN CALL ERRWRT(-1, & ' Program will rely on residue and atom names. No checking') CALL ERRWRT(-1, & ' If this option is used then monomers should be checked' & //' carefully before using') ELSEIF(MAKE_CHECK.EQ.'N') THEN CALL ERRWRT(-1, & ' Apart from amino acids and DNA/RNA all monomers will be ' & //'checked to see if atom names and connectivity is correct') ENDIF IF(MAKE_HFLAG.EQ.'A') THEN CALL ERRWRT(-1, & ' Hydrogens will be restored in their riding positions') ELSEIF(MAKE_HFLAG.EQ.'Y') THEN CALL ERRWRT(-1, & ' Hydrogens in input coordinate file will be kept') ELSEIF(MAKE_HFLAG.EQ.'N') THEN CALL ERRWRT(-1, & ' Hydrogens will not be written to the output file') ENDIF IF(MAKE_HFLAG_O.EQ.'Y') THEN CALL ERRWRT(-1, & ' hydrogens will be written to the output file') ENDIF IF(MAKE_RFLAG.EQ.'Y') & CALL ERRWRT(-1, & ' Missing atoms will be restored') IF(MAKE_CHECK_SPEC.EQ.'Y') THEN CALL ERRWRT(-1, & ' Atoms in special positions will be treated') WRITE(LINE,'(A,F10.3)') & ' Minimum distance for special position crieteria ', & MAKE_DMIN_SPEC CALL ERRWRT(-1,LINE) ENDIF IF(MAKE_PEPT_FLAG.EQ.'Y') & CALL ERRWRT(-1, & ' L-D peptides will be checked and corrected') IF(MAKE_LNK_FLAG.EQ.'Y'.OR.MAKE_LNK_FLAG.EQ.'D') THEN CALL ERRWRT(-1, & ' Links between monomers will be checked and corrected') ELSE CALL ERRWRT(-1, & ' Links between monomers will be checked. Only those links' & //' present in the coordinate file will be used') ENDIF IF(MAKE_SUGAR_FLAG.EQ.'Y') THEN CALL ERRWRT(-1, & ' All links to sugar will be analysed and used') ELSEIF(MAKE_SUGAR_FLAG.EQ.'S') THEN CALL ERRWRT(-1, & ' Standard sugar links will be analysed and used') ELSEIF(MAKE_SUGAR_FLAG.EQ.'N') THEN CALL ERRWRT(-1, & ' Sugar links present in the input file will used') ELSEIF(MAKE_SUGAR_FLAG.EQ.'D') THEN CALL ERRWRT(-1, & ' Sugar links in the input file will be ignored. ' & //'Coordinates will be analysed for sugar links and' & //' used if found') ENDIF IF(MAKE_NEWL_VALUE_FLAG.EQ.'Y') THEN CALL ERRWRT(-1, & ' For new ligands "ideal restraint" value will be taken' & //' the input coordinates') ELSE CALL ERRWRT(-1, & ' For new ligands "ideal restraint" values will be taken' & //' from the energetic libary ener_lib.cif') ENDIF IF(MAKE_CONN_FLAG.EQ.'Y') THEN ELSE ENDIF IF(MAKE_SYMM_FLAG.EQ.'Y') THEN CALL ERRWRT(-1, & ' Symmetry related links will be analysed and used') ELSE CALL ERRWRT(-1, & ' Symmetry related links will not be analysed') ENDIF IF(MAKE_CHAIN_FLAG.EQ.'Y') THEN ELSE ENDIF IF(MAKE_CIS_FLAG.EQ.'Y') THEN CALL ERRWRT(-1, & ' Cis peptides will be found and used automatically') ELSE CALL ERRWRT(-1, & ' Cis peptides will be found and used if they are present' & //' in the coordinate file') ENDIF CALL ERRWRT(-1,' ') CALL ERRWRT(-1,' ') ENDIF c C---Solvent parameters IF(SOLVENT_FLAG) THEN ENDIF C List rigid bodies: IF(MODE.EQ.'RIGI') THEN CALL HEADER('Domain Definition') IF(NDOMAIN.LE.0) THEN WRITE(LINE,'(A)')' No domains have been defined. ' & //'All atoms will be refined as one rigid body' CALL ERRWRT(-1,LINE) ELSE DO II = 1,NDOMAIN WRITE(LINE,'(A,I4,A,I4)')' Group:',II, + ': No. of pieces:',IDOMAIN_PIECES(II) CALL ERRWRT(-1,LINE) DO III = 1,IDOMAIN_PIECES(II) IF( EXCLUDE_DOMAIN(II) .EQ. 'NONE') + WRITE(LINE,'(A,A,A,2I5,A)') ' Chain: ', & IDOMAIN_CHN(iii,ii), + ' Span:',IDOMAIN_FROM(III,II),IDOMAIN_TO(III,II), + ' ** All atoms **' IF( EXCLUDE_DOMAIN(II) .EQ. 'SCHA') + WRITE(LINE,'(A,A,A,2I5,A)') ' Chain: ', & IDOMAIN_CHN(iii,ii), + ' Span:',IDOMAIN_FROM(III,II),IDOMAIN_TO(III,II) , + ' ** Mainchain only **' IF( EXCLUDE_DOMAIN(II) .EQ. 'MCHA') + WRITE(LINE,'(A,A,A,2I5,A)') ' Chain: ', & IDOMAIN_CHN(iii,ii), + ' Span:',IDOMAIN_FROM(III,II),IDOMAIN_TO(III,II) , + ' ** Sidechain only **' CALL ERRWRT(-1,LINE) ENDDO CALL ERRWRT(-1,' ') ENDDO END IF END IF C IF(REFID.NE.'IDEA') THEN IF(REFS.EQ.'LSQF') WRITE(LINE,'(A)') +' Residual : Least Squares for Fs' IF(REFS.EQ.'LSQI') WRITE(LINE,'(A)') +' Residual : Least Squares for Is' IF(REFS.EQ.'MLKF'.AND. .NOT. (MIR_FLAG .OR. PHASE_FLAG)) THEN WRITE(LINE,'(A,A)')' Residual :', + ' Rice Maximum Likelihood for Fs' CALL ERRWRT(-1,LINE) ELSE IF(REFS.EQ.'MLKF'.AND.(MIR_FLAG .OR. PHASE_FLAG) ) THEN WRITE(LINE,'(A,A)') &' Residual :', +' Phase modified Maximum Likelihood for Fs' CALL ERRWRT(-1,LINE) WRITE(LINE,'(A,2F8.2)') +' Phase Blurred by Scale*Exp(-B s**2) :', + PHAS_BLUR_SCAL,PHAS_BLUR_BVAL CALL ERRWRT(-1,LINE) ENDIF CALL HEADER('Least-square scaling parameters') CALL ERRWRT(-1,'Overall scale') IF(B_LS_OVER_FLAG) CALL ERRWRT(-1,'Overall B value') IF(B_LS_ANISO_OVER_FLAG) & CALL ERRWRT(-1,'Overall anisotropic B with tr(B) = 0.0') IF(BULK_LS_FLAG) CALL ERRWRT(-1,'Bulk solvent based on'// & ' Babinet"s principle') IF(SOLVENT_FLAG) THEN CALL ERRWRT(-1,'Constant bulk solvent in non protein region') WRITE(LINE,'(A,F8.3)')'Probe radii for non-ions ',PROB_VDW CALL ERRWRT(-1,LINE) WRITE(LINE,'(A,F8.3)')'Probe radii for ions ',PROB_ION CALL ERRWRT(-1,LINE) WRITE(LINE,'(A,F8.3)')'Shrinkage of the mask by ', & RADII_SHRINK CALL ERRWRT(-1,LINE) ENDIF CALL ERRWRT(-1,' ') ENDIF C IF(MODE.EQ.'HKRF') THEN IF(SOLVMIN.EQ.'CGMA') WRITE(LINE,'(A)') + ' Method of minimisation : Sparse Matrix ' IF(SOLVMIN.EQ.'CGRA') WRITE(LINE,'(A)') + ' Method of minimisation : Conjugate Gradient' IF(SOLVMIN.EQ.'CDIR') WRITE(LINE,'(A)') + ' Method of minimisation : Conjugate Direction' CALL ERRWRT(-1,LINE) ENDIF C IF( REFID.NE.'IDEA'.AND.LEXPUSE) THEN WRITE(LINE,'(A)')' Experimental sigmas used for weighting' CALL ERRWRT(-1,LINE) END IF C IF( REFID.NE.'IDEA' ) THEN C Find a reasonable upper limit for number of reflections to include. REsmin = 0.5/STLMIN REsmax = 0.5/STLMAX HMAX = INT(CELL(1)/RESMAX) KMAX = INT(CELL(2)/RESMAX) LMAX = INT(CELL(3)/RESMAX) C SZ = INT(1.2*(2+HMAX)*(2+KMAX)*(2+LMAX)*2*3.20/(3*NSYM)) CALL FIND_CENTR_SYM(NumSymmetry,MaxSym,RealSymmMatrx, + IFACTOR_CC,ERROR) NOBS = IFACTOR_CC* + INT(1.2*(1.0+REAL(HMAX))*(1.0+REAL(KMAX))* & (1.0+REAL(LMAX))*2*3.20/(3.0*REAL(NSYM))) IF( .NOT.LEXPUSE) THEN WRITE(LINE,'(A)') + ' Experimental sigmas not used for weighting:' CALL ERRWRT(-1,LINE) END IF WRITE(LINE,'(A,3X,I3,5x,F8.4)') + ' Number of Bins and width:',NBIN, RANGE CALL ERRWRT(-1,LINE) ENDIF IF(MODE.EQ.'HKRF'.AND.REFID.NE.'IDEA') THEN IF(ITEMP.EQ.1.OR.ITEMP.EQ.-1) WRITE(LINE,'(A)') + ' Refinement of individual isotropic Bfactors' IF(ITEMP.EQ.2) WRITE(LINE,'(A)') + ' Refinement of individual anisotropic Bfactors' IF(ITEMP.EQ.0) WRITE(LINE,'(A)') + ' Refinement of one overall Bfactor' IF(ITEMP.EQ.3) WRITE(LINE,'(A)') + ' Refinement of mixed isotropic and anisotropic Bfactors' CALL ERRWRT(-1,LINE) REsmin = 0.5/STLMIN REsmax = 0.5/STLMAX WRITE(LINE,'(A,3x,2F8.4)') + ' Refinement resln :',ResMin,ResMax CALL ERRWRT(-1,LINE) WRITE(LINE,'(A,3X,I8)') +' Estimated number of reflections :',NOBS CALL ERRWRT(-1,LINE) IF ( LFreeRexcludeVal .NE.-999) THEN WRITE(LINE,'(A,3X,I3)') + ' Free R exclusion - flag equals:',LFreeRexcludeVal CALL ERRWRT(-1,LINE) END IF END IF C IF(MODE.EQ.'HKRF'.AND.REFID.NE.'IDEA') THEN IF(WEIGHT.EQ.'MATR') THEN WRITE(LINE,'(A)') + ' Weighting by comparison of trace of matrix' ELSEIF(WEIGHT.EQ.'AUTO') THEN WRITE(LINE,'(A)')' Auto weighting. An attempt' ELSE WRITE(LINE,'(A)') ' Weighting by comparison of gradients' ENDIF CALL ERRWRT(-1,LINE) IF(WEIGHT.NE.'AUTO') THEN WRITE(LINE,'(A,3X,2F8.4)') + ' Weighting parameters :',WEIGHTXMAT CALL ERRWRT(-1,LINE) ENDIF WRITE(LINE,'(A,3X,I3)') + ' Refinement cycles :', NCCREF CALL ERRWRT(-1,LINE) ENDIF IF(REFID.NE.'IDEA') THEN C WRITE(LINE,'(A)')' Scaling type :' CALL ERRWRT(-1,LINE) C IF(NSCOPT.EQ.0 ) WRITE(LINE,'(A)') + ' Wilson using 1 Gaussian ' IF(NSCOPT.EQ.1 ) WRITE(LINE,'(A)') + ' Bulk solvent using using Babinet principle' CALL ERRWRT(-1,LINE) IF(.NOT.LSUSEWORK .AND. LSEXPUSE) WRITE(LINE,'(A)') + ' using free set of reflns and experimental sigmas' IF(.NOT.LSUSEWORK .AND. .NOT.LSEXPUSE) WRITE(LINE,'(A)') + ' using free set of reflns but not experimental sigmas' IF(LSUSEWORK .AND. LSEXPUSE) WRITE(LINE,'(A)') + ' using working set of reflns and experimental sigmas' IF(LSUSEWORK .AND. .NOT.LSEXPUSE) WRITE(LINE,'(A)') + ' using working set of reflns but not experimental sigmas' CALL ERRWRT(-1,LINE) ENDIF C CALL ERRWRT(-1,' ') IF(REFID.NE.'IDEA'.AND.REFS.EQ.'MLKF') THEN WRITE(LINE,'(A)')' Estimation of SigmaA Using 2 Gaussians: ' CALL ERRWRT(-1,LINE) IF(.NOT.MLUSEWORK .AND.MLEXPUSE ) WRITE(LINE,'(A)') + ' using free set of reflns with experimental sigmas' IF(.NOT.MLUSEWORK .AND..NOT. MLEXPUSE ) WRITE(LINE,'(A)') + ' using free set of reflns without experimental sigmas' IF(MLUSEWORK .AND.MLEXPUSE ) WRITE(LINE,'(A)') + ' using working set of reflns with experimental sigmas' IF(MLUSEWORK .AND..NOT. MLEXPUSE ) WRITE(LINE,'(A)') + ' using working set of reflns without experimental sigmas' CALL ERRWRT(-1,LINE) ENDIF C IF(REFID.NE.'IDEA') THEN IF(.NOT. PHASE_SIGMAA_FLAG .AND.(MIR_FLAG.OR.PHASE_FLAG)) + WRITE(LINE,'(A)') + ' Input phases not used in SigmaA estimation' IF( PHASE_SIGMAA_FLAG .AND.(MIR_FLAG.OR.PHASE_FLAG)) + WRITE(LINE,'(A)') + ' Input phases used in SigmaA estimation' CALL ERRWRT(-1,LINE) CALL ERRWRT(-1,' ') ENDIF IF(NPART.GT.0.AND.REFID.NE.'IDEA') THEN WRITE(LINE,'(A,I4)')' Number of external partial structures', + NPART CALL ERRWRT(-1,LINE) ENDIF NSCPART = 0 IF(FPART_FLAG.AND.REFID.NE.'IDEA') THEN DO IP=1,NMAXPART IF(ISCPART(IP).EQ.1) NSCPART = NSCPART + 1 ENDDO ENDIF IF(NSCPART.GT.0.AND.REFID.NE.'IDEA') THEN WRITE(LINE,'(A)') + ' Partial structures flagged 1 scaled independently from FC' CALL ERRWRT(-1,LINE) ENDIF IF(REFID.NE.'IDEA') THEN RSSCMN = 0.5/SMINS RSSCMX = 0.5/SMAXS WRITE(LINE,'(A,3X,2F8.4)')' Scaling and SigmaA resln:', + RSSCMN,RSSCMX CALL ERRWRT(-1,LINE) CALL ERRWRT(-1,' ') ENDIf C--- Write out damping factors C IF(MODE.EQ.'HKRF') THEN WRITE(LINE,'(A,3X,2F8.4)')' Damping factors:', + PDAMP,BDAMP CALL ERRWRT(-1,LINE) CALL ERRWRT(-1,' ') ENDIF C--- Write out restraint information here. C---- Geometrical Restraints + Temp + Occ C IF(MODE.EQ.'HKRF'.AND.REFID.NE.'UNRE') THEN CALL HEADER('Geometry restraints and weights') C CALL ERRWRT(-1,' ') WRITE(LINE,'(46X,A)')'Sigma:' CALL ERRWRT(-1,LINE) CALL ERRWRT(-1,' Bonding distances') WRITE(LINE,'(10X,A,F5.2)')'Weight = ',WDSKAL CALL ERRWRT(-1,LINE) CALL ERRWRT(-1,' ') CALL ERRWRT(-1,' Bond angles') WRITE(LINE,'(10X,A,F5.2)')'Weight = ',WASKAL CALL ERRWRT(-1,LINE) C CALL ERRWRT(-1,' ') WRITE (ISYSW, '(A)')' Planar groups' WRITE(ISYSW, '(10X,A,F5.2)')'WEIGHT=',WPSKAL C CALL ERRWRT(-1,' ') CALL ERRWRT(-1,' Chiral centers') WRITE(LINE,'(10X,A,F5.2)')'Weight=', WCSKAL CALL ERRWRT(-1,LINE) C CALL ERRWRT(-1,' ') CALL ERRWRT(-1,' NON-BONDED CONTACTS') WRITE(LINE,'(10X,A,F5.2)') & 'Overall weight = ',WVSKAL CALL ERRWRT(-1,LINE) WRITE(LINE,'(10X,A,F5.2)') & 'Sigma for simple VDW = ',VDW_SDI_VDW CALL ERRWRT(-1,LINE) WRITE(LINE,'(10X,A,F5.2)') & 'Sigma for VDW trhough torsion angle = ',VDW_SDI_TORSION CALL ERRWRT(-1,LINE) WRITE(LINE,'(10X,A,F5.2)') & 'Sigma for HBOND = ',VDW_SDI_HBOND CALL ERRWRT(-1,LINE) WRITE(LINE,'(10X,A,F5.2)') & 'Sigma for metal-ion = ',VDW_SDI_METAL CALL ERRWRT(-1,LINE) WRITE(LINE,'(10X,A,F5.2)') & 'Sigma for DUMMY and other atom = ',VDW_SDI_DUMMY CALL ERRWRT(-1,LINE) WRITE(LINE,'(10X,A,F5.2,A)') & 'Distance for donor-accepetor = vdw1+vdw2+(',HBOND_DINC_AD,')' CALL ERRWRT(-1,LINE) WRITE(LINE,'(10X,A,F5.2,A)') & 'Distance for acceptor - H = vdw1+ (',HBOND_DINC_AH,')' CALL ERRWRT(-1,LINE) WRITE(LINE,'(10X,A,F5.2,A)') & 'VDW distance through torsion = vdw1+vdw2+(',DINC_TORSION,')' CALL ERRWRT(-1,LINE) WRITE(LINE,'(10X,A,F5.2,A)') & 'Distance for DUMMY-others = vdw1+vdw2+(',DINC_DUMMY,')' CALL ERRWRT(-1,LINE) C CALL ERRWRT(-1,' ') CALL ERRWRT(-1,' TORSION ANGLES') WRITE(LINE,'(10X,A,F5.2)')'Weight=',WTSKAL CALL ERRWRT(-1,LINE) C IF (ITEMP.GT.0) THEN CALL ERRWRT(-1,' ') CALL ERRWRT(-1,' THERMAL FACTORS') WRITE(ISYSW,'(10X,A,F5.2)')'Weight=',WBSKAL WRITE(ISYSW,'(5X,A,T45,F5.2,A)') + 'Main chain bond (1-2 neighbour)',SIGB(1),'A**2' WRITE(ISYSW,'(5X,A,T45,F5.2,A)') + 'Main chain angle (1-3 neighbour)',SIGB(2),'A**2' WRITE(ISYSW,'(5X,A,T45,F5.2,A)') + 'Side chain bond',SIGB(3),'A**2' WRITE(ISYSW,'(5X,A,T45,F5.2,A)') + 'Side chain angle',SIGB(4),'A**2' END IF C IF (NUMBER_NCSR.GT.0.AND.MODE.EQ.'HKRF') THEN CALL HEADER('NCS restraints parameters') CALL ERRWRT(-1,' ') WRITE(LINE,'(A,I5)') + ' Number of different NCS restraints ',NUMBER_NCSR CALL ERRWRT(-1,LINE) CALL ERRWRT(-1,' ') DO INCS=1,NUMBER_NCSR WRITE(LINE,'(A,I5)')'NCS restraint :',INCS CALL ERRWRT(-1,LINE) WRITE(LINE,'(A,I5)')'Number of chains : ', & NCS_N_CHAIN(INCS) CALL ERRWRT(-1,LINE) ALL_CHAINS = ' ' DO IN=1,NCS_N_CHAIN(INCS) IF(LENSTR(ALL_CHAINS).GT.0) THEN ALL_CHAINS=ALL_CHAINS(1:LENSTR(ALL_CHAINS)) & //' '//NCS_CHAINS(IN,INCS) ELSE ALL_CHAINS=' '//NCS_CHAINS(IN,INCS) ENDIF ENDDO IF(LENSTR(ALL_CHAINS).GT.0) THEN WRITE(LINE,'(A,A)')'Chain names :', & ALL_CHAINS(1:LENSTR(ALL_CHAINS)) ELSE CALL ERRWRT(1,'NCS chain definitions. CHECK NCSR/NONX') ENDIF CALL ERRWRT(-1,LINE) WRITE(*,*)' Spans ',NCS_SPANS(INCS) DO IN=1,NCS_SPANS(INCS) WRITE(LINE,'(A,I6,A,I6,A,I5,A,I5)')'Span ',IN,', From ', & NCS_IRES_FIRST(IN,INCS), & ' to ',NCS_IRES_LAST(IN,INCS), & ', weighting code',NCS_ICODE(IN,INCS) CALL ERRWRT(-1,LINE) ENDDO CALL ERRWRT(-1,' ') ENDDO WRITE(ISYSW,'(10X,A,F5.2)')'Weight=',WSSKAL WRITE(ISYSW,'(5X,A,T45,F5.2,A)') + 'Positional, tight class', SIGS(1),'A' WRITE(ISYSW,'(5X,A,T45,F5.2,A)') + 'Positional, medium class', SIGS(2),'A' WRITE(ISYSW,'(5X,A,T45,F5.2,A)') + 'Positional, weak class', SIGS(3),'A' WRITE(ISYSW,'(5X,A,T45,F5.2,A)') + 'Thermal, tight class', SIGS(4),'A**2' WRITE(ISYSW,'(5X,A,T45,F5.2,A)') + 'Thermal, medium class', SIGS(5),'A**2' WRITE(ISYSW,'(5X,A,T45,F5.2,A)') + 'Thermal, weak class', SIGS(6),'A**2' cd CALl ERRWRT(1,'After NCS report') END IF C CALL ERRWRT(-1,' ') CALL ERRWRT(-1,' RESTRAINTS AGAINST EXCESSIVE SHIFTS') WRITE(LINE,'(5x,A,T45,F5.2,A)') + 'Positional parameters',PDEL,'A' CALL ERRWRT(-1,LINE) WRITE(LINE,'(5x,A,T45,F5.2,A)') + 'Thermal parameters',BDEL*PISQ8,'A' CALL ERRWRT(-1,LINE) WRITE(LINE,'(5x,A,T45,F5.2)') + 'Occupancy parameters',QDEL CALL ERRWRT(-1,LINE) CALL ERRWRT(-1,' ') CALL ERRWRT(-1,' RADIUS OF CONFIDENCE') WRITE(LINE,'(5x,A,F5.2,A)') + 'Positional parameters',PRADIUS,'A' CALL ERRWRT(-1,LINE) WRITE(LINE,'(5x,A,F5.2,A)') + 'Thermal parameters ',BRADIUS,'A**2' CALL ERRWRT(-1,LINE) WRITE(LINE,'(5x,A,F5.2)') + 'Occupancy parameters ',QRADIUS CALL ERRWRT(-1,LINE) ENDIF C C----Monitoring parameters CALL ERRWRT(-1,' ') IF(MON_STYLE.EQ.'NONE') THEN CALL ERRWRT(-1,'Monitoring style is "NONE". No information' & //' will be printed out') ENDIF IF(MON_STYLE.EQ.'FEW') THEN CALL ERRWRT(-1,'Monitoring style is "FEW". Minimum information' & //' will be printed out') ENDIF IF(MON_STYLE.EQ.'MEDI') THEN CALL ERRWRT(-1,'Monitoring style is "MEDIUM". Complete' & //' information will be printed out in the') CALL ERRWRT(-1,'first and last cycle. In all other cycles' & //' minimum information will be printed out') ENDIF IF(MON_STYLE.EQ.'MANY') THEN CALL ERRWRT(-1,'Monitoring style is "MANY". Complete' & //' information will be printed out in all cycles') ENDIF IF(MON_STYLE.EQ.'MEDI'.OR.MON_STYLE.EQ.'MANY'.AND. & REFID.EQ.'REST') THEN CALL ERRWRT(-1,'Sigma cutoffs for printing out outliers') CALL ERRWRT(-1,'If deviation of restraint parameter >' & //' alpha*sigma then information will be printed out') WRITE(LINE,'(A,F6.3)') 'Distance outliers ',DSCUT CALL ERRWRT(-1,LINE) WRITE(LINE,'(A,F6.3)') 'Angle outliers ',ANGLCUT CALL ERRWRT(-1,LINE) WRITE(LINE,'(A,F6.3)') 'Torsion outliers ',TORCUT CALL ERRWRT(-1,LINE) WRITE(LINE,'(A,F6.3)') 'Chiral volume outliers ',CHICUT CALL ERRWRT(-1,LINE) WRITE(LINE,'(A,F6.3)') 'Plane outliers ',PLCUT CALL ERRWRT(-1,LINE) WRITE(LINE,'(A,F6.3)') 'Non-bonding outliers ',BADVDW CALL ERRWRT(-1,LINE) IF(ITEMP.GT.0) THEN WRITE(LINE,'(A,F6.3)') 'B value outliers ',BFAC_CUT CALL ERRWRT(-1,LINE) IF(ITEMP.GT.1) THEN WRITE(LINE,'(A,F6.3)') 'Rigid bond outliers ',RBON_CUT CALL ERRWRT(-1,LINE) WRITE(LINE,'(A,F6.3)') 'Sphericity outliers ',BSPH_CUT CALL ERRWRT(-1,LINE) ENDIF ENDIF IF(NUMBER_NCSR.GT.0) THEN WRITE(LINE,'(A,F6.3)') 'NCS outliers ',NCSR_CUT CALL ERRWRT(-1,LINE) ENDIF IF(ITEMP.GT.1) THEN ENDIF ENDIF CALL ERRWRT(-1, &'---------------------------------------------------------------') CALL ERRWRT(-1,' ') RETURN END C SUBROUTINE READ_BFAC_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP,FVALUE, & CVALUE,IERROR) C C---Reads parameters relevant to Bvalues IMPLICIT NONE INCLUDE 'weights.fh' INCLUDE 'refi_flags.fh' INCLUDE 'const.fh' C INTEGER NTOK,ITOK,IERROR INTEGER IBEG(*),IEND(*),ITYP(*) REAL FVALUE(*) CHARACTER LINE*(*),CVALUE(*)*4 C INTEGER ITK REAL BDefault_Ind C ITK = ITOK IF(NTOK.LT.ITOK) RETURN IF(ITYP(ITK).EQ.2) THEN CALL GTNREA(ITK,1,WBSKAL,NTOK,ITYP,FVALUE) ITK = ITK + 1 ELSE GOTO 100 ENDIF IF(NTOK.LT.ITK) RETURN IF(ITYP(ITK).EQ.2) THEN CALL GTNREA(ITK,1,SIGB(1),NTOK,ITYP,FVALUE) ITK = ITK + 1 ELSE GOTO 100 ENDIF IF(NTOK.LT.ITK) RETURN IF(ITYP(ITK).EQ.2) THEN CALL GTNREA(ITK,1,SIGB(2),NTOK,ITYP,FVALUE) ITK = ITK + 1 ELSE GOTO 100 ENDIF IF(NTOK.LT.ITK) RETURN IF(ITYP(ITK).EQ.2) THEN CALL GTNREA(ITK,1,SIGB(3),NTOK,ITYP,FVALUE) ITK = ITK + 1 ELSE GOTO 100 ENDIF IF(NTOK.LT.ITK) RETURN IF(ITYP(ITK).EQ.2) THEN CALL GTNREA(ITK,1,SIGB(4),NTOK,ITYP,FVALUE) ITK = ITK + 1 ELSE GOTO 100 ENDIF 100 CONTINUE IF(NTOK.LT.ITK) RETURN IF(ITYP(ITK).EQ.1) THEN IF(CVALUE(ITK)(1:3).EQ.'SET') THEN ITK = ITK + 1 IF(NTOK.GE.ITK) CALL GTNREA(ITK,1,BDefault_Ind,NTOK,ITYP, & FVALUE) IF(Bdefault_Ind.GT.0.0) THEN BSET_DEFAULT_FLAG = .TRUE. UDefault_Ind = BDefault_Ind/PISQ8 ENDIF ENDIF ENDIF RETURN END C SUBROUTINE READ_OCCUP_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP,FVALUE, & CVALUE,IERROR) C C---Reads parameters relevant to Bvalues IMPLICIT NONE INCLUDE 'atom_com.fh' INCLUDE 'weights.fh' INCLUDE 'refi_flags.fh' INCLUDE 'occupancy_params.fh' INCLUDE 'const.fh' C INTEGER NTOK,ITOK,IERROR INTEGER IBEG(*),IEND(*),ITYP(*) REAL FVALUE(*) CHARACTER LINE*(*),CVALUE(*)*4 C INTEGER ITK REAL BDefault_Ind C ITK = ITOK IF(NTOK.LT.ITK) RETURN IF(CVALUE(ITK)(1:4).EQ.'REFI') THEN OCCUP_REF_FLAG = .TRUE. ITK = ITK + 1 ELSE IF(CVALUE(ITK).EQ.'EVER') THEN ITK = ITK + 1 CALL GTNINT(ITK,1,NCYCLE_OCC,NTOK,ITYP, & FVALUE) ITK = ITK + 1 ELSE IF(CVALUE(ITK).EQ.'BVAL') THEN ITK = ITK + 1 IF(CVALUE(ITK).EQ.'EXCL') THEN EXCLUDE_OCC_B = .TRUE. ITK = ITK + 1 ELSEIF(CVALUE(ITK).EQ.'NOEX') THEN EXCLUDE_OCC_B = .FALSE. ITK = ITK + 1 ELSE CALL ERRWRT(0,'Wrong subkeywrod of "OCCUPancy BVALue') CALL ERRWRT(0,'Allowed subkeywrods are EXCLUDE/NOEXCLUDE') ENDIF ELSE CALL ERRWRT(0,'Wrong subkeywords of OCCUPancy') CALL ERRWRT(0,'Allowed subkeywords are "REFIne EVERy BVALue') ENDIF RETURN END C SUBROUTINE READ_NBOND_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP,FVALUE, & CVALUE,IERROR) C C---Reads parameters relevant to Bvalues IMPLICIT NONE INCLUDE 'weights.fh' INCLUDE 'refi_flags.fh' INCLUDE 'const.fh' C INTEGER NTOK,ITOK,IERROR INTEGER IBEG(*),IEND(*),ITYP(*) REAL FVALUE(*) CHARACTER LINE*(*),CVALUE(*)*4 C INTEGER ITK C IERROR = 0 ITK = ITOK IF(NTOK.LT.ITOK) GOTO 200 IF(ITYP(ITK).EQ.2) THEN CALL GTNREA(ITK,1,WVSKAL,NTOK,ITYP,FVALUE) ITK = ITK + 1 ENDIF 100 CONTINUE C C---First try to read overall weighting factor for non-bonding ineteractions IF(ITK.GE.NTOK) GOTO 200 IF(CVALUE(ITK).NE.'OVER'.AND.CVALUE(ITK).NE.'SIGM'.AND. & CVALUE(ITK).NE.'INCR'.AND.CVALUE(ITK).NE.'CHAN'.AND. & CVALUE(ITK).NE.'VDWC' ) THEN IERROR = IERROR + 1 CALL ERRWRT(-1,'Wrong subkeyword of VDWR/VAND/NONB keyword') CALL ERRWRT(-1,'Allowed subkeywords -'// & ' OVERall/SIGMa/INCRement/CHANge') CALL ERRWRT(0,'Keyword interpretation has failed') IERROR = 1 GOTO 200 ENDIF IF(CVALUE(ITK).EQ.'OVER') THEN IF(ITK.LT.NTOK) THEN ITK = ITK + 1 IF(ITYP(ITK).NE.2) THEN IERROR = IERROR + 1 CALL ERRWRT(-1,'Wrong parameter for VDW/VAND/NBOND OVER') CALL ERRWRT(-1,'Program expects number') CALL ERRWRT(0,'Keyword interpretation has failed') GOTO 200 ENDIF IF(ITK.GE.NTOK) GOTO 200 CALL GTNREA(ITK,1,WVSKAL,NTOK,ITYP,FVALUE) ITK = ITK + 1 ENDIF ENDIF C C---Read sigmas for nonbonding interactions IF(CVALUE(ITK).EQ.'SIGM') THEN ITK = ITK + 1 150 CONTINUE IF(ITK.GE.NTOK) GOTO 200 IF(CVALUE(ITK).EQ.'SIGM'.OR.CVALUE(ITK).EQ.'OVER'.OR. & CVALUE(ITK).EQ.'INCR'.OR.CVALUE(ITK).EQ.'CHAN') GOTO 100 IF(CVALUE(ITK)(1:3).NE.'VDW' .AND.CVALUE(ITK).NE.'HBON'.AND. & CVALUE(ITK) .NE.'META'.AND.CVALUE(ITK).NE.'TORS'.AND. & CVALUE(ITK) .NE.'DUMM' ) THEN CALL ERRWRT(-1,'Wrong subkeyword of VDW/VAND/NBON SIGMa') CALL ERRWRT(-1, & 'Allowed subkeywords - VDW/HBON/METAl/TORS/DUMM') CALL ERRWRT(0,'Keyword interpretation has failed') GOTO 200 ENDIF IF(ITK.GE.NTOK) GOTO 200 IF(ITYP(ITK+1).NE.2) THEN CALL ERRWRT(-1,'Wrong parameter field. Expecting number') CALL ERRWRT(0,'Keyword interpretation has failed') GOTO 200 ENDIF IF(CVALUE(ITK)(1:3).EQ.'VDW') THEN ITK = ITK + 1 CALL GTNREA(ITK,1,VDW_SDI_VDW,NTOK,ITYP,FVALUE) ITK = ITK + 1 GOTO 150 ELSEIF(CVALUE(ITK).EQ.'HBON') THEN ITK = ITK + 1 CALL GTNREA(ITK,1,VDW_SDI_HBOND,NTOK,ITYP,FVALUE) ITK = ITK + 1 GOTO 150 ELSEIF(CVALUE(ITK).EQ.'META') THEN ITK = ITK + 1 CALL GTNREA(ITK,1,VDW_SDI_METAL,NTOK,ITYP,FVALUE) ITK = ITK + 1 GOTO 150 ELSEIF(CVALUE(ITK).EQ.'TORS') THEN ITK = ITK + 1 CALL GTNREA(ITK,1,VDW_SDI_TORSION,NTOK,ITYP,FVALUE) ITK = ITK + 1 GOTO 150 ELSEIF(CVALUE(ITK).EQ.'DUMM') THEN ITK = ITK + 1 CALL GTNREA(ITK,1,VDW_SDI_DUMMY,NTOK,ITYP,FVALUE) ITK = ITK + 1 GOTO 150 ENDIF ENDIF C C---Incrementation parameters IF(CVALUE(ITK).EQ.'INCR') THEN ITK = ITK + 1 170 CONTINUE IF(ITK.GT.NTOK) GOTO 200 IF(CVALUE(ITK).EQ.'SIGM'.OR.CVALUE(ITK).EQ.'OVER'.OR. & CVALUE(ITK).EQ.'INCR'.OR.CVALUE(ITK).EQ.'CHAN') GOTO 100 IF(CVALUE(ITK).NE.'TORS'.AND.CVALUE(ITK).NE.'ADHB'.AND. & CVALUE(ITK).NE.'AHHB'.AND.CVALUE(ITK).NE.'DUMM') THEN CALL ERRWRT(-1,'Wrong subkeyword of VDW/VAND/NBON INCR') CALL ERRWRT(-1,'Allowed subkeywords - TORS/ADHB/AHHB/DUMM') CALL ERRWRT(0,'Keyword interpretation has failed') GOTO 200 ENDIF IF(ITK.GE.NTOK) GOTO 200 IF(ITYP(ITK+1).NE.2) THEN CALL ERRWRT(-1,'Wrong parameter field. Expecting number') CALL ERRWRT(0,'Keyword interpretation has failed') GOTO 200 ENDIF IF(CVALUE(ITK).EQ.'TORS') THEN ITK = ITK + 1 CALL GTNREA(ITK,1,DINC_TORSION,NTOK,ITYP,FVALUE) DINC_TORSION = -ABS(DINC_TORSION) ITK = ITK + 1 GOTO 170 ELSEIF(CVALUE(ITK).EQ.'ADHB') THEN ITK = ITK + 1 CALL GTNREA(ITK,1,HBOND_DINC_AD,NTOK,ITYP,FVALUE) HBOND_DINC_AD = -ABS(HBOND_DINC_AD) ITK = ITK + 1 GOTO 170 ELSEIF(CVALUE(ITK).EQ.'AHHB') THEN ITK = ITK + 1 CALL GTNREA(ITK,1,HBOND_DINC_AH,NTOK,ITYP,FVALUE) HBOND_DINC_AH = ABS(HBOND_DINC_AH) ITK = ITK + 1 GOTO 170 ELSEIF(CVALUE(ITK).EQ.'DUMM') THEN ITK = ITK + 1 CALL GTNREA(ITK,1,DINC_DUMMY,NTOK,ITYP,FVALUE) DINC_DUMMY = -ABS(DINC_DUMMY) ITK = ITK + 1 GOTO 170 ENDIF ENDIF C IF(CVALUE(ITK).EQ.'CHAN') THEN IF(ITK.GE.NTOK) GOTO 200 ITK = ITK + 1 ENDIF IF(CVALUE(ITK).EQ.'VDWC') THEN IF(ITK.GE.NTOK) GOTO 200 ITK = ITK+1 IF(ITYP(ITK).EQ.2) THEN CALL GTNREA(ITK,1,DVDW_CUT_MIN,NTOK,ITYP,FVALUE) IF(DVDW_CUT_MIN.LT.0.0) THEN CALL ERRWRT(0,'Wrong vdw cut radius. Reset to 2.0') DVDW_CUT_MIN = 2.0 ENDIF DVDW_CUT_MIN_X = DVDW_CUT_MIN ITK = ITK + 1 ENDIF ENDIF GOTO 100 200 CONTINUE RETURN END C SUBROUTINE READ_RESTR_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP, & FVALUE,CVALUE,IERROR) C C---Reads parameters relevant to B_values IMPLICIT NONE INCLUDE 'weights.fh' INCLUDE 'refi_flags.fh' INCLUDE 'const.fh' INCLUDE 'restr_params.fh' C INTEGER NTOK,ITOK,IERROR INTEGER IBEG(*),IEND(*),ITYP(*) REAL FVALUE(*) CHARACTER LINE*(*),CVALUE(*)*4 CHARACTER RES_NAME_RESTR_INP*8,GROUP_NAME_RESTR_INP*16 CHARACTER LINK_NAME_INP*8,RES_NAME_TORS_INP*8,FLAG_TORS*1 C REAL TORS_VALUE_INP,TORS_SIGMA_INP INTEGER TORS_PERIOD_INP C INTEGER ITK,IRESID,ITORS_REST,I_T,I INTEGER ERROR_RESTR EXTERNAL ERROR_RESTR C IERROR = 0 ITK = ITOK IF(NTOK.LT.ITOK) GOTO 200 IF(CVALUE(2)(1:4).EQ.'TORS') THEN C C--Read info about restrainable torsions and write them to some C--file. Syntax: C---RESTraint TORSion RESIdue NAME VALUe PERIod C-- C C---Next key should be RESI ITK = ITK + 1 IF(ITK.GT.NTOK) GOTO 200 IF(CVALUE(ITK).EQ.'INCL') THEN ITK = ITK + 1 CALL READ_TORS_PARAMS_CARD(ITK,NTOK,CVALUE, & LINE,IBEG,IEND, & FVALUE,RES_NAME_RESTR_INP,GROUP_NAME_RESTR_INP, & LINK_NAME_INP,RES_NAME_TORS_INP, & TORS_VALUE_INP,TORS_SIGMA_INP,TORS_PERIOD_INP, & FLAG_TORS) IF(FLAG_TORS.EQ.'N') THEN N_RESTRAIN_TORS = 0 GOTO 200 ELSE C c---Check if this particular torsion is in the list. If yes replace C---replace it. IF(N_RESTRAIN_TORS.GT.0) THEN DO I=1,N_RESTRAIN_TORS IF(RES_NAME_TORS_RESTR(I).EQ.RES_NAME_RESTR_INP.AND. & GROUP_NAME_TORS_RESTR(I).EQ.GROUP_NAME_RESTR_INP.AND. & LINK_NAME_TORS_RESTR(I).EQ.LINK_NAME_INP.AND. & RES_NAME_TORS_NAME(I).EQ.RES_NAME_TORS_INP) THEN I_T = I GOTO 50 ENDIF ENDDO ENDIF N_RESTRAIN_TORS = N_RESTRAIN_TORS + 1 I_T = N_RESTRAIN_TORS 50 CONTINUE RES_NAME_TORS_RESTR(I_T) = RES_NAME_RESTR_INP GROUP_NAME_TORS_RESTR(I_T) = GROUP_NAME_RESTR_INP LINK_NAME_TORS_RESTR(I_T) = LINK_NAME_INP RES_NAME_TORS_NAME(I_T) = RES_NAME_TORS_INP RES_NAME_TORS_VALUE(I_T) = TORS_VALUE_INP WRITE(*,*) TORS_VALUE_INP RES_NAME_TORS_SIGMA(I_T) = TORS_SIGMA_INP RES_NAME_TORS_PERIOD(I_T) = TORS_PERIOD_INP GOTO 200 ENDIF ELSE IF(CVALUE(ITK).EQ.'EXCL') THEN ITK = ITK + 1 CALL READ_TORS_PARAMS_CARD(ITK,NTOK,CVALUE, & LINE,IBEG,IEND, & FVALUE,RES_NAME_RESTR_INP,GROUP_NAME_RESTR_INP, & LINK_NAME_INP,RES_NAME_TORS_INP, & TORS_VALUE_INP,TORS_SIGMA_INP,TORS_PERIOD_INP, & FLAG_TORS) IF(FLAG_TORS.EQ.'N') THEN N_RESTRAIN_TORS_E = 0 GOTO 200 ELSE IF(N_RESTRAIN_TORS_E.GT.0) THEN DO I=1,N_RESTRAIN_TORS_E IF(RES_NAME_TORS_RESTR_E(I).EQ.RES_NAME_RESTR_INP.AND. & GROUP_NAME_TORS_RESTR_E(I).EQ.GROUP_NAME_RESTR_INP.AND. & LINK_NAME_TORS_RESTR_E(I).EQ.LINK_NAME_INP.AND. & RES_NAME_TORS_NAME_E(I).EQ.RES_NAME_TORS_INP) THEN I_T = I GOTO 60 ENDIF ENDDO ENDIF N_RESTRAIN_TORS_E = N_RESTRAIN_TORS_E + 1 I_T = N_RESTRAIN_TORS_E 60 CONTINUE RES_NAME_TORS_RESTR_E(I_T) = RES_NAME_RESTR_INP GROUP_NAME_TORS_RESTR_E(I_T) = GROUP_NAME_RESTR_INP LINK_NAME_TORS_RESTR_E(I_T) = LINK_NAME_INP RES_NAME_TORS_NAME_E(I_T) = RES_NAME_TORS_INP GOTO 200 ENDIF ENDIF ENDIF C IF(CVALUE(2)(1:4).EQ.'RESI') THEN ITK = ITK + 1 IF(NTOK.LE.ITK) GOTO 100 NCIS_TRANS_RES = NCIS_TRANS_RES + 1 CALL GTNINT(ITK,1,IRESID,NTOK,ITYP,FVALUE) CIS_TRANS_RES(NCIS_TRANS_RES) = IRESID ITK = ITK + 1 IF(NTOK.LE.ITK) GOTO 100 CIS_TRANS_CHAIN(NCIS_TRANS_RES) = CVALUE(ITK)(1:1) ITK = ITK + 1 IF(NTOK.LT.ITK) GOTO 100 IF(CVALUE(ITK)(1:3).EQ.'ALT') THEN ITK = ITK + 1 IF(NTOK.LE.ITK) GOTO 100 CIS_TRANS_ALT(NCIS_TRANS_RES) = CVALUE(ITK)(1:1) ITK = ITK + 1 ELSE CIS_TRANS_ALT(NCIS_TRANS_RES) = '.' ENDIF CIS_TRANS_VALUE(NCIS_TRANS_RES) = CVALUE(ITK)(1:3) ELSEIF(CVALUE(2).EQ.'REPL') THEN IF(CVALUE(ITK).EQ.'CHIR') THEN ITK = ITK + 1 IF(NTOK.LE.ITK) GOTO 150 NCHIR_REPLACE = NCHIR_REPLACE + 1 CALL GTNINT(ITK,1,IRESID,NTOK,ITYP,FVALUE) CHIR_REPL_RES(NCHIR_REPLACE) = IRESID ITK = ITK + 1 IF(NTOK.LE.ITK) GOTO 150 CHIR_REPL_CHAIN(NCHIR_REPLACE) = CVALUE(ITK)(1:1) ITK = ITK + 1 IF(ITOK.LE.ITK) GOTO 150 CHIR_REPL_ATOM(NCHIR_REPLACE) = CVALUE(ITK) ITK = ITK + 1 IF(ITK.GT.NTOK) GOTO 150 IF(CVALUE(ITK)(1:3).EQ.'ALT') THEN ITK = ITK + 1 IF(NTOK.LE.ITK) GOTO 150 CHIR_REPL_ALT(NCHIR_REPLACE) = CVALUE(ITK)(1:1) ITK = ITK + 1 ELSE CHIR_REPL_ALT(NCHIR_REPLACE) = '.' ENDIF IF(NTOK.LE.ITK) GOTO 150 IF(CVALUE(ITK).EQ.'SIGN') THEN ITK = ITK + 1 CHIR_REPL_SIGN(NCHIR_REPLACE) = CVALUE(ITK)(1:1) ENDIF ENDIF ENDIF GOTO 200 100 CONTINUE CALL ERRWRT(-1,' ') CALL ERRWRT(-1,'Wrong instructions for CIS/TRANS') CALL ERRWRT(-1,'Valid instruction is:') CALL ERRWRT(-1, & 'RESTraint RESIdue ALT CIS/TRANS') CALL ERRWRT(-1,' is optional. All others are compolsury') CALL ERRWRT(1,'Severe problem in keyword interpretation') C 150 CONTINUE CALL ERRWRT(-1,' ') CALL ERRWRT(-1,'Wrong instructions for RESTR REPLACE CHIRAL') CALL ERRWRT(-1,'Valid instruction is:') CALL ERRWRT(-1, & 'RESTraint REPLACE CHIRal ALT '// & ' CIS/TRANS') CALL ERRWRT(-1,' is optional. All others are compolsury') CALL ERRWRT(1,'Severe problem in keyword interpretation') 200 CONTINUE RETURN END C INTEGER FUNCTION ERROR_RESTR(ITK,NTOK) IMPLICIT NONE INTEGER ITK,NTOK C ERROR_RESTR = 0 IF(ITK.GT.NTOK) THEN CALL ERRWRT(0,'Incomplete keyword for torsion restraints') CALL ERRWRT(0,'Valid form is:') ERROR_RESTR = 1 ENDIF RETURN END C SUBROUTINE READ_TORS_PARAMS_CARD(ITK,NTOK,CVALUE, * LINE,IBEG,IEND, & FVALUE,RES_NAME_TORS_RESTR_O,GROUP_NAME_TORS_RESTR_O, & LINK_NAME_TORS_RESTR_O,RES_NAME_TORS_NAME_O, & RES_NAME_TORS_VALUE_O,RES_NAME_TORS_SIGMA_O, & RES_NAME_TORS_PERIOD_O,FLAG_TORS) IMPLICIT NONE C C--Reads from card necessary information about torsion to be restrained C--or excluded. Residue range should be added also. C INTEGER ITK,NTOK,N_RESTRAIN_O,RES_NAME_TORS_PERIOD_O INTEGER IBEG(*),IEND(*) REAL RES_NAME_TORS_VALUE_O,RES_NAME_TORS_SIGMA_O REAL FVALUE(*) CHARACTER CVALUE(*)*4,LINE*(*) CHARACTER RES_NAME_TORS_RESTR_O*(*),GROUP_NAME_TORS_RESTR_O*(*) CHARACTER LINK_NAME_TORS_RESTR_O*(*),RES_NAME_TORS_NAME_O*(*) CHARACTER FLAG_TORS C INTEGER ERROR_RESTR,I_T EXTERNAL ERROR_RESTR C FLAG_TORS = 'Y' RES_NAME_TORS_VALUE_O = -1.0E32 RES_NAME_TORS_SIGMA_O = -0.1 RES_NAME_TORS_PERIOD_O = -1 RES_NAME_TORS_RESTR_O = '.' GROUP_NAME_TORS_RESTR_O = '.' RES_NAME_TORS_NAME_O = '.' LINK_NAME_TORS_RESTR_O = '.' IF(CVALUE(ITK).EQ.'NONE') THEN FLAG_TORS = 'N' ITK = ITK + 1 GOTO 200 ELSE IF(CVALUE(ITK).EQ.'RESI') THEN ITK = ITK + 1 IF(ERROR_RESTR(ITK,NTOK).GT.0) GOTO 200 RES_NAME_TORS_RESTR_O = LINE(IBEG(ITK):IEND(ITK)) ITK = ITK + 1 IF(ERROR_RESTR(ITK,NTOK).GT.0) GOTO 200 ELSEIF(CVALUE(ITK).EQ.'GROU') THEN ITK = ITK + 1 IF(ERROR_RESTR(ITK,NTOK).GT.0) GOTO 200 GROUP_NAME_TORS_RESTR_O = LINE(IBEG(ITK):IEND(ITK)) ITK = ITK + 1 IF(ERROR_RESTR(ITK,NTOK).GT.0) GOTO 200 ELSE IF(CVALUE(ITK).EQ.'LINK') THEN C C---It is about links. ITK = ITK + 1 IF(ERROR_RESTR(ITK,NTOK).GT.0) GOTO 200 LINK_NAME_TORS_RESTR_O = LINE(IBEG(ITK):IEND(ITK)) ITK = ITK + 1 IF(ERROR_RESTR(ITK,NTOK).GT.0) GOTO 200 ELSE I_T = ERROR_RESTR(ITK,NTOK) GOTO 200 ENDIF C C-- 20 CONTINUE IF(ITK.GT.NTOK) THEN GOTO 200 ENDIF IF(CVALUE(ITK).EQ.'NAME') THEN ITK = ITK + 1 RES_NAME_TORS_NAME_O = LINE(IBEG(ITK):IEND(ITK)) ELSE IF(CVALUE(ITK).EQ.'VALU') THEN ITK = ITK + 1 RES_NAME_TORS_VALUE_O = FVALUE(ITK) ELSE IF(CVALUE(ITK).EQ.'SIGM') THEN ITK = ITK + 1 RES_NAME_TORS_SIGMA_O = FVALUE(ITK) ELSE IF(CVALUE(ITK).EQ.'PERI') THEN ITK = ITK + 1 RES_NAME_TORS_PERIOD_O = NINT(FVALUE(ITK)) ENDIF IF(ERROR_RESTR(ITK,NTOK).GT.0) GOTO 200 ITK = ITK + 1 GOTO 20 ENDIF 200 CONTINUE RETURN END C SUBROUTINE READ_SYMM_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP, & FVALUE) c c---Reads keyword for symmetry IMPLICIT NONE INCLUDE 'celsym.fh' C CHARACTER LINE*(*) CHARACTER SGNM*10,PGNAM*10 REAL FVALUE(*) INTEGER NTOK,ITOK INTEGER IBEG(*),IEND(*),ITYP(*) INTEGER NPSYM REAL RT(4,4,192) C INTEGER NSYM_L INTEGER IERROR C CALL CCPUPC(LINE) CALL RDSYMM(ITOK,LINE,IBEG,IEND,ITYP,FVALUE,NTOK,SGNM,ISPNO, + PGNAM,NSYM_L,NumSymmetry,RealSymmMatrx) C CALL CHECK_SYMMETRY4(SGNM,ISPNO,NSYM_L,RT,IERROR) C RETURN END C SUBROUTINE CHECK_SYMMETRY4(SPGRP,NSPGRP,NSYM_IN,ROT_IN,IERROR) c c---It checks. If symmetry has been defined previously (space group number C---is more than 1) then it uses that symmetry. If it has not been defined C---then new symmetry is used. space group number is important. It might c---be weekness of this routine IMPLICIT NONE INCLUDE 'celsym.fh' INTEGER NSPGRP,IERROR,NSYM_IN REAL ROT_IN(4,4,*) CHARACTER SPGRP*(*) INTEGER I,J,IS INTEGER LENSTR IERROR = 0 C C--First check if space group numbers are same IF(ISPNO.LE.1.AND.NSPGRP.GT.1) THEN C C---Symmetry has not been defined previously. Use new symmetry DO IS=1,NSYM_IN DO J=1,4 DO I=1,4 RealSymmMatrx(I,J,IS) = ROT_IN(I,J,IS) ENDDO ENDDO ENDDO NumSymmetry = NSYM_IN ISPNO = NSPGRP IF(LENSTR(SPGRP).GT.0) THEN SpaceGroupName = SPGRP(1:LENSTR(SPGRP)) ELSE SpaceGroupName = ' ' ENDIF IERROR = 0 RETURN ELSEIF(ISPNO.GT.1.AND.NSPGRP.LE.1) THEN C C---There is no new symmetry. But old symmetry has been defined. Use old C---symmetry DO IS=1,NumSymmetry DO J=1,4 DO I=1,4 ROT_IN(I,J,IS) = RealSymmMatrx(I,J,IS) ENDDO ENDDO ENDDO NSYM_IN = NumSymmetry NSPGRP = ISPNO IF(LENSTR(SpaceGroupName).GT.0) THEN SPGRP = SpaceGroupName(1:LENSTR(SpaceGroupName)) ELSE CALL ERRWRT(-1,'Space group name has not been defined') ENDIF IERROR = 1 RETURN ELSEIF(ISPNO.NE.NSPGRP) THEN C C---Space group names are different. It is serious error IERROR = 2 RETURN ELSE C C---Space group number is same. Check and make other parameters c---of symmetry consistent with each other ENDIF END C SUBROUTINE SOLVENT_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP,FVALUE, & CVALUE,IERROR) IMPLICIT NONE INCLUDE 'solvent.fh' INTEGER NTOK,ITOK,IERROR INTEGER IBEG(*),IEND(*),ITYP(*) REAL FVALUE(*) CHARACTER LINE*(*),CVALUE(*)*4 c c---Local variables INTEGER ITTB,ITT C IERROR = 0 ITTB = 2 IF(CVALUE(2).EQ.'NO') THEN SOLVENT_FLAG = .FALSE. ITTB = 3 RETURN ELSEIF(CVALUE(2).EQ.'YES') THEN SOLVENT_FLAG = .TRUE. ITTB = 3 ENDIF DO ITT = ITTB,NTOK,2 IF(CVALUE(ITT).EQ.'VDWP') THEN IF(ITYP(ITT+1).EQ.2) & CALL GTNREA(ITT+1,1,PROB_VDW,NTOK,ITYP,FVALUE) ELSEIF(CVALUE(ITT).EQ.'IONP') THEN IF(ITYP(ITT+1).EQ.2) & CALL GTNREA(ITT+1,1,PROB_ION,NTOK,ITYP,FVALUE) ELSEIF(CVALUE(ITT).EQ.'RSHR') THEN IF(ITYP(ITT+1).EQ.2) & CALL GTNREA(ITT+1,1,RADII_SHRINK,NTOK,ITYP,FVALUE) ELSE IF(CVALUE(ITT).EQ.'BFIX') THEN B_LS_SOLVENT_MASK_FLAG = .FALSE. IF(ITYP(ITT+1).EQ.2) THEN CALL GTNREA(ITT+1,1,B_LS_SOL_M,NTOK,ITYP,FVALUE) ENDIF ELSE IF(CVALUE(ITT).EQ.'SCFI') THEN SCALE_LS_SOLVENT_MASK_FLAG = .FALSE. IF(ITYP(ITT+1).EQ.2) THEN CALL GTNREA(ITT+1,1,SCALE_LS_SOL_M,NTOK,ITYP,FVALUE) ENDIF ENDIF ENDDO RETURN END C SUBROUTINE MONITOR_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP,FVALUE, & CVALUE,IERROR) c c---Reads and processes keywords relevant to monitoring of statistics C---during work of program IMPLICIT NONE INCLUDE 'monitor.fh' INTEGER NTOK,ITOK,IERROR INTEGER IBEG(*),IEND(*),ITYP(*) REAL FVALUE(*) CHARACTER LINE*(*),CVALUE(*)*4 c c---Local variables INTEGER ITTB,ITT C C---First check if second key is 'MANY', 'FEW' or 'MEDI'. Onlyy FEW and MEDI C---are important. IERROR = 0 ITTB = 2 IF(CVALUE(2).EQ.'FEW' .OR.CVALUE(2).EQ.'MANY'.OR. + CVALUE(2).EQ.'MEDI'.OR.CVALUE(2).EQ.'TEST') THEN MON_STYLE = CVALUE(2) ITTB = 3 ENDIF DO ITT = ITTB,NTOK,2 IF(CVALUE(ITT).EQ.'TORS')THEN IF(ITYP(ITT+1).EQ.2) & CALL GTNREA(ITT+1,1,TORCUT,NTOK,ITYP,FVALUE) ELSEIF(CVALUE(ITT).EQ.'CHIR') THEN IF(ITYP(ITT+1).EQ.2) & CALL GTNREA(ITT+1,1,CHICUT,NTOK,ITYP,FVALUE) ELSEIF(CVALUE(ITT).EQ.'DIST') THEN IF(ITYP(ITT+1).EQ.2) & CALL GTNREA(ITT+1,1,DSCUT,NTOK,ITYP,FVALUE) ELSEIF(CVALUE(ITT).EQ.'ANGL') THEN IF(ITYP(ITT+1).EQ.2) & CALL GTNREA(ITT+1,1,ANGLCUT,NTOK,ITYP,FVALUE) ELSEIF(CVALUE(ITT).EQ.'PLAN') THEN IF(ITYP(ITT+1).EQ.2) & CALL GTNREA(ITT+1,1,PLCUT,NTOK,ITYP,FVALUE) ELSEIF(CVALUE(ITT)(1:3).EQ.'VDW'.OR. & CVALUE(ITT)(1:3).EQ.'VAN'.OR.CVALUE(ITT).EQ.'NBON') THEN IF(ITYP(ITT+1).EQ.2) & CALL GTNREA(ITT+1,1,BADVDW,NTOK,ITYP,FVALUE) ELSEIF(CVALUE(ITT).EQ.'BSPH') THEN IF(ITYP(ITT+1).EQ.2) & CALL GTNREA(ITT+1,1,BSPH_CUT,NTOK,ITYP,FVALUE) ELSEIF(CVALUE(ITT).EQ.'RBON') THEN IF(ITYP(ITT+1).EQ.2) & CALL GTNREA(ITT+1,1,RBON_CUT,NTOK,ITYP,FVALUE) ELSEIF(CVALUE(ITT).EQ.'BFAC') THEN IF(ITYP(ITT+1).EQ.2) & CALL GTNREA(ITT+1,1,BFAC_CUT,NTOK,ITYP,FVALUE) ELSEIF(CVALUE(ITT).EQ.'NCSR') THEN IF(ITYP(ITT+1).EQ.2) & CALL GTNREA(ITT+1,1,NCSR_CUT,NTOK,ITYP,FVALUE) ELSEIF(CVALUE(ITT).EQ.'BADC') THEN IF(ITYP(ITT+1).EQ.2) & CALL GTNREA(ITT+1,1,BAD_CONT,NTOK,ITYP,FVALUE) ELSE WRITE(*,*)CVALUE(ITT),CVALUE(ITT-1) CALL ERRWRT(0,' Unknown subkeyword of MONI ') CALL ERRWRT(0,' ????? '//CVALUE(ITT)//' ????? ') IERROR = IERROR + 1 ENDIF ENDDO IF(DSCUT.LT.0.0 ) DSCUT = 10.0 IF(ANGLCUT.LT.0.0) ANGLCUT = 10.0 IF(TORCUT.LT.0.0 ) TORCUT = 10.0 IF(CHICUT.LT.0.0 ) CHICUT = 10.0 IF(PLCUT.LT.0.0 ) PLCUT = 10.0 IF(BADVDW.LT.0.0 ) BADVDW = 3.0 IF(BAD_CONT.LT.0.0) BAD_CONT = 1.0 IF(BSPH_CUT.LT.0.0) BSPH_CUT = 10.0 IF(RBON_CUT.LT.0.0) RBON_CUT = 10.0 IF(BFAC_CUT.LT.0.0) BFAC_CUT = 10.0 IF(NCSR_CUT.LT.0.0) NCSR_CUT = 10.0 RETURN END C SUBROUTINE WEIGHT_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP,FVALUE, & CVALUE,IERROR) c c---Read parameters relevant to weighting X-ray and geometry IMPLICIT NONE INCLUDE 'weights.fh' INTEGER NTOK,ITOK,IERROR INTEGER IBEG(*),IEND(*),ITYP(*) REAL FVALUE(*) CHARACTER LINE*(*),CVALUE(*)*4 C INTEGER ITT,ITK C IERROR = 0 IF(NTOK.LT.2) RETURN ITK = ITOK DO ITT=ITOK,NTOK IF(CVALUE(ITK).EQ.'NOEX')THEN LEXPUSE = .FALSE. ITK = ITK + 1 ELSEIF(CVALUE(ITK).EQ.'EXPE') THEN LEXPUSE = .TRUE. ITK = ITK + 1 ELSEIF(CVALUE(ITK).EQ.'AUTO') THEN WEIGHT = 'AUTO' ITK = ITK + 1 ELSEIF(CVALUE(ITK).EQ.'MATR') THEN WEIGHT = 'MATR' ITK = ITK+1 WEIGHTXMAT = 0.5 IF(NTOK.GE.ITK)THEN CALL GTNREA(ITK,1,WEIGHTXMAT,NTOK,ITYP,FVALUE) ITK = ITK+1 ENDIF ELSEIF(CVALUE(ITK).EQ.'GRAD') THEN WEIGHT = 'GRAD' WEIGHTXMAT = 1.0 ITK = ITK+1 IF(NTOK.GE.ITK)THEN CALL GTNREA(ITK,1,WEIGHTXMAT,NTOK,ITYP,FVALUE) ITK = ITK+1 ENDIF ELSEIF(CVALUE(ITK).EQ.'SIGM') THEN CALL ERRWRT(-1,'This is an out of date weighting scheme') CALL ERRWRT(-1,'Use WEIGht MATRix instead') CALL ERRWRT(-1,'Starting value for is 0.5') CALL ERRWRT + (1,'I suspect you are using an old script with a new version') ELSE CALL ERRWRT(-1,' ') CALL ERRWRT(0,'No such weighting scheme '//CVALUE(1) & //CVALUE(ITK)) CALL ERRWRT(-1,' ') IERROR = IERROR + 1 ENDIF IF(ITK.GT.NTOK) RETURN ENDDO C RETURN END C SUBROUTINE SCALE_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP,FVALUE, & CVALUE,IERROR) IMPLICIT NONE INCLUDE 'agreem.fh' INCLUDE 'weights.fh' INCLUDE 'const.fh' C C---Reads keywords relevant to scaling of obsreved and calculated C---structure factors INTEGER NTOK,ITOK,IERROR INTEGER IBEG(*),IEND(*),ITYP(*) REAL FVALUE(*) CHARACTER LINE*(*),CVALUE(*)*4 REAL RSSCMN,RSSCMX,SSSCMN,SSSCMX INTEGER ITT,ITK CHARACTER SCKEY*4 C IERROR = 0 ITK=ITOK IF(NTOK.LE.ITOK) RETURN DO ITT=ITOK,NTOK-1 IF(CVALUE(ITK).EQ.'BAVE') THEN C C---Keep Average B-value of molecule BAVER_MOLEC. Could be usefull C---for low res refinement BAVER_MOLEC = -100.0 IF(NTOK.GT.ITK) THEN ITK = ITK+1 CALL GTNREA(ITK,1,BAVER_MOLEC,NTOK,ITYP,FVALUE) UAVER_MOLEC = BAVER_MOLEC/PISQ8 ENDIF C Allow these scaling types: BULK or SIMPLE ELSEIF(CVALUE(ITK).EQ.'TYPE') THEN ITK = ITK+1 SCKEY = CVALUE(ITK)(1:4) IF(SCKEY.NE.'BULK'.AND.SCKEY.NE.'SIMP') THEN CALL ERRWRT(-1,' Wrong Scaling type option') IERROR = IERROR + 1 ENDIF IF(SCKEY.EQ.'BULK') THEN BULK_LS_FLAG = .TRUE. ML_BULK_REFINE_FLAG = .TRUE. cd D_ML_SCALE_BBULK = 0.1 D_ML_B_BBULK = 100.0 NSCOPT = 1 ENDIF IF(SCKEY.EQ.'SIMP') THEN BULK_LS_FLAG = .FALSE. ML_BULK_REFINE_FLAG = .FALSE. D_ML_SCALE_BBULK = 0.0 D_ML_B_BBULK = 100.0 NSCOPT = 0 ENDIF ITK = ITK+1 ELSEIF(CVALUE(ITK).EQ.'LSSC') THEN C C---For LS scaling ITK = ITK + 1 IF(CVALUE(ITK).NE.'FREE'.AND.CVALUE(ITK).NE.'NCYC'.AND. & CVALUE(ITK).NE.'EXPE'.AND.CVALUE(ITK).NE.'ANIS'.AND. + CVALUE(ITK).NE.'ISOT'.AND.CVALUE(ITK).NE.'FIXB'.AND. + CVALUE(ITK).NE.'APPL'.AND.CVALUE(ITK).NE.'TYPE') THEN CALL ERRWRT(-1, + 'Wrong option for scaling SCAL LSSC'//CVALUE(ITK)) IERROR = IERROR + 1 END IF C Need to worry about either order.. 666 CONTINUE IF(ITK.GT.NTOK) RETURN IF(CVALUE(ITK).EQ.'FIXB') THEN ITK = ITK+1 667 CONTINUE IF(CVALUE(ITK)(1:1).EQ.'B') THEN ITK = ITK+1 IF(NTOK.GE.ITK) THEN CALL GTNREA(ITK,1,BLS_DEFINED,NTOK,ITYP,FVALUE) B_LS_BULK_REFINE_FLAG = .FALSE. B_LS_BULK = ABS(BLS_DEFINED) ITK = ITK+1 ENDIF GOTO 667 ELSEIF(CVALUE(ITK)(1:1).EQ.'S') THEN ITK = ITK+1 IF(NTOK.GE.ITK) THEN CALL GTNREA(ITK,1,SCLS_DEFINED,NTOK,ITYP,FVALUE) SCALE_LS_BULK = ABS(SCLS_DEFINED) SCALE_LS_BULK_REFINE_FLAG = .FALSE. ITK = ITK+1 ENDIF GOTO 667 END IF GOTO 666 END IF IF(CVALUE(ITK).EQ.'FREE') THEN ITK = ITK+1 LSUSEWORK = .FALSE. GO TO 666 END IF IF(CVALUE(ITK).EQ.'ANIS') THEN B_LS_ANISO_OVER_FLAG = .TRUE. B_LS_ANISO_OVER_REFINE_FLAG = .TRUE. ILSSCALTYPOV = 1 LSSCALTYPE = 'ANISO' ITK = ITK+1 C C---Aniso scale. Apply to observed 'OBSE', to calculated (default) 'CALC' IF(ITK+1.LE.NTOK) THEN IF(CVALUE(ITK).EQ.'APPL') THEN IF(CVALUE(ITK+1).EQ.'OBSE') THEN APPLY_SCALE_TO = 'OBSE' ELSE APPLY_SCALE_TO = 'CALC' ENDIF ITK = ITK+2 ENDIF ENDIF GOTO 666 ENDIF IF(CVALUE(ITK).EQ.'ISOT') THEN B_LS_ANISO_OVER_FLAG = .FALSE. B_LS_ANISO_OVER_REFINE_FLAG = .FALSE. ILSSCALTYPOV = 0 LSSCALTYPE = 'ISOTR' ITK = ITK+1 C C---iso scale. It has no effect. It is for just reducing user dependent error IF(ITK+1.LE.NTOK) THEN IF(CVALUE(ITK).EQ.'APPL') THEN IF(CVALUE(ITK+1).EQ.'OBSE') THEN APPLY_SCALE_TO = 'OBSE' ELSE APPLY_SCALE_TO = 'CALC' ENDIF ITK = ITK+2 ENDIF ENDIF GOTO 666 ENDIF C Maybe next word is NCYC? IF(CVALUE(ITK).EQ.'NCYC') THEN CALL GTNINT(ITK+1,1,NLSCYCL,NTOK,ITYP,FVALUE) ITK = ITK+2 GO TO 666 END IF IF(CVALUE(ITK).EQ.'EXPE') THEN ITK = ITK+1 LSEXPUSE = .TRUE. GO TO 666 END IF IF(CVALUE(ITK).EQ.'TYPE') THEN ITK = ITK+1 SCKEY = CVALUE(ITK)(1:4) IF(SCKEY.NE.'BULK'.AND.SCKEY.NE.'SIMP') THEN CALL ERRWRT(-1,' Wrong Scaling type option') IERROR = IERROR + 1 ENDIF IF(SCKEY.EQ.'BULK') THEN BULK_LS_FLAG = .TRUE. ENDIF IF(SCKEY.EQ.'SIMP') THEN BULK_LS_FLAG = .FALSE. ENDIF ITK = ITK+1 ENDIF C ELSEIF(CVALUE(ITK).EQ.'MLSC') THEN ITK = ITK + 1 IF(CVALUE(ITK).NE.'WORK' .AND. CVALUE(ITK).NE.'NCYC' + .AND.CVALUE(ITK).NE.'NOEX'.AND.CVALUE(ITK).NE.'ANIS'.AND. + CVALUE(ITK).NE.'ISOT'.AND.CVALUE(ITK).NE.'FIXB') THEN CALL ERRWRT(-1,'Wrong option for scaling SCAL MLSC'//CVALUE(ITK)) IERROR = IERROR + 1 END IF C Need to worry about either order.. 777 CONTINUE IF(CVALUE(ITK).EQ.'FIXB') THEN ITK = ITK+1 778 CONTINUE IF(CVALUE(ITK)(1:1).EQ.'B') THEN ITK = ITK+1 IF(NTOK.GE.ITK) THEN CALL GTNREA(ITK,1,BML_DEFINED,NTOK,ITYP,FVALUE) MLBFIX = .TRUE. ITK = ITK+1 ENDIF GOTO 778 ELSEIF(CVALUE(ITK)(1:1).EQ.'S') THEN ITK = ITK+1 IF(NTOK.GE.ITK) THEN CALL GTNREA(ITK,1,SCML_DEFINED,NTOK,ITYP,FVALUE) MLSCFIX = .TRUE. ITK = ITK+1 ENDIF GOTO 778 ENDIF GOTO 777 END IF IF(CVALUE(ITK).EQ.'WORK') THEN MLUSEWORK = .TRUE. ITK = ITK+1 GO TO 777 END IF IF(CVALUE(ITK).EQ.'ANIS') THEN IMLSCALTYPOV = 1 MLSCALTYPE = 'ANISO' ITK=ITK+1 GOTO 777 ENDIF IF(CVALUE(ITK).EQ.'ISOT') THEN IMLSCALTYPOV = 0 MLSCALTYPE = 'ISOTR' ITK=ITK+1 GOTO 777 ENDIF C Maybe next word is NCYC? IF(CVALUE(ITK).EQ.'NCYC') THEN CALL GTNINT(ITK+1,1,NMLCYCL,NTOK,ITYP,FVALUE) ITK = ITK+2 GO TO 777 END IF IF(CVALUE(ITK).EQ.'NOEX') THEN ITK = ITK+1 MLEXPUSE = .FALSE. GO TO 777 END IF C---Scaling type: Isotropic or anisotropic ELSEIF(CVALUE(ITK).EQ.'ALLS') THEN ITK = ITK + 1 IF(CVALUE(ITK).EQ.'ANIS') THEN IMLSCALTYPOV = 1 ILSSCALTYPOV = 1 MLSCALTYPE = 'ANISO' LSSCALTYPE = 'ANISO' ELSEIF(CVALUE(ITK).EQ.'ISOT') THEN IMLSCALTYPOV = 0 ILSSCALTYPOV = 0 MLSCALTYPE = 'ISOTR' LSSCALTYPE = 'ISOTR' ENDIF C---Resolution limits for scaling ELSEIF(CVALUE(ITK).EQ.'RESO') THEN ITK = ITK + 1 CALL RDRESO(ITK,ITYP,FVALUE,NTOK,RSSCMN,RSSCMX,SSSCMN, + SSSCMX) SMINS = SQRT(SSSCMN)/2.0 SMAXS = SQRT(SSSCMX)/2.0 ITK = ITK+2 ELSEIF(CVALUE(ITK).EQ.'APPL') THEN C C---Apply overall B-value to observed or calculated str.factors ITK = ITK+1 IF(CVALUE(ITK).EQ.'OBSE') THEN APPLY_SCALE_TO = 'OBSE' ITK = ITK+1 ELSE APPLY_SCALE_TO = 'CALC' ITK = ITK+1 ENDIF ELSE CALL ERRWRT(-1,' Unknown subkeyword of SCAL ') CALL ERRWRT(-1,' ????? '//CVALUE(ITK)//' ????? ') IERROR = IERROR + 1 ENDIF IF(ITK.GE.NTOK) RETURN ENDDO C RETURN END C SUBROUTINE READ_HYDROGEN_PARS(NTOK,ITOK,LINE,IBEG,IEND,ITYP, & FVALUE,CVALUE,IERROR) IMPLICIT NONE INCLUDE 'refi_flags.fh' INCLUDE 'atom_com.fh' INCLUDE 'tls.fh' INCLUDE 'weights.fh' INCLUDE 'vitals.fh' C C---Input and output parameters INTEGER NTOK,ITOK,IERROR INTEGER IBEG(*),IEND(*),ITYP(*) REAL FVALUE(*) CHARACTER CVALUE(*)*4,LINE(*) C c---Local parameters INTEGER ITK C IERROR = 0 ITK = ITOK+1 10 CONTINUE IF(CVALUE(ITK).EQ.'REFI'.OR.CVALUE(ITK).EQ.'NORE'.OR. & CVALUE(ITK).NE.'BVAL') THEN IF(CVALUE(ITK).EQ.'REFI') THEN HYDROGEN_REFINE_FLAG = .TRUE. ITK = ITK + 1 GOTO 10 ELSEIF(CVALUE(ITK).EQ.'NORE') THEN HYDROGEN_REFINE_FLAG = .FALSE. ITK = ITK + 1 GOTO 10 ELSEIF(CVALUE(ITK).EQ.'BVAL') THEN ITK = ITK + 1 IF(ITK.GT.NTOK) GOTO 100 IF(CVALUE(ITK).EQ.'ISOT') THEN HYDROGEN_BVALUE = 'ISOT' ELSEIF(CVALUE(ITK).EQ.'ANIS') THEN HYDROGEN_BVALUE = 'ANIS' ELSE CALL ERRWRT(0,'Wrong subkeyword for REFI BVAL') CALL ERRWRT(0,'Acceptable subkeywords are:') CALL ERRWRT(0,'ISOT - isotropic refinement') CALL ERRWRT(0,'ANIS - Bvalue as of parent atom') IERROR = 1 GOTO 100 ENDIF GOTO 10 ENDIF ELSE CALL ERRWRT(0,'Wrong subkeyword of HYDRogens') CALL ERRWRT(0,'Acceptable subkeywords are:') CALL ERRWRT(0,'REFI - refine hydrogens') CALL ERRWRT(0,'NORE - Use hydrogens for idealisation and'// & ' structure factors calculation only') CALL ERRWRT(0,'BVAL - style for B value refinement') IERROR = 1 ENDIF 100 CONTINUE RETURN END C SUBROUTINE REFI_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP,FVALUE, & CVALUE,IERROR) IMPLICIT NONE INCLUDE 'refi_flags.fh' INCLUDE 'atom_com.fh' INCLUDE 'tls.fh' INCLUDE 'weights.fh' INCLUDE 'vitals.fh' INTEGER NTOK,ITOK,IERROR INTEGER IBEG,IEND,ITYP(*) REAL FVALUE(*) CHARACTER LINE*(*),CVALUE(*)*4 C INTEGER I INTEGER IFIRST,ILAST CHARACTER CHNID*1 REAL SMN INTEGER ITK C Set defaults ITK=ITOK IF(NTOK.LE.ITOK) RETURN DO ITOK=2,NTOK-1 C Allow these refinement types: RESTrained, UNREstrained, IDEAlise RIGId IF(CVALUE(ITK).EQ.'TYPE') THEN ITK = ITK+1 IF(CVALUE(ITK).EQ.'IDEA') REFUSE = .FALSE. IF ( REFID.NE.'REST'.AND.REFID.NE.'UNRE'.AND. & REFID.NE.'IDEA'.AND.REFID.NE.'RIGI'.AND. & REFID.NE.'TLSR'.AND.REFID.NE.'TLSC'.AND. & REFID.NE.'XNON'.AND.REFID.NE.'EXCL') THEN CALL ERRWRT(-1,' Wrong refinement option') IERROR = IERROR + 1 ENDIF REFID = CVALUE(ITK)(1:4) ITK = ITK + 1 C---Type of residuals ELSEIF(CVALUE(ITK).EQ.'RESI') THEN ITK = ITK+1 REFS = CVALUE(ITK) IF ( REFS.NE.'LSQF'.AND.REFS.NE.'LSQI'.AND. & REFS.NE.'MLKF') THEN CALL ERRWRT(-1,' Wrong residual option') IERROR = IERROR + 1 ENDIF ITK = ITK+1 C---Resolution limits for refinement ELSEIF(CVALUE(ITK).EQ.'RESO') THEN ITK = ITK+1 CALL RDRESO(ITK,ITYP,FVALUE,NTOK,ResMin,ResMax,STLMIN, + STLMAX) SMN = STLMIN STLMIN = SQRT(STLMIN)/2.0 STLMAX = SQRT(STLMAX)/2.0 ITK = ITK+2 ELSEIF(CVALUE(ITK).EQ.'BREF') THEN ITK = ITK+1 ITEMP = 1 IF(CVALUE(ITK).EQ.'ISOT') ITEMP = 1 IF(CVALUE(ITK).EQ.'ANIS') ITEMP = 2 IF(CVALUE(ITK).EQ.'OVER') ITEMP = 0 IF(CVALUE(ITK).EQ.'MIXE') ITEMP = 3 IF(CVALUE(ITK).EQ.'ONLY') ITEMP = -1 IF(ITEMP.EQ.999) THEN CALL ERRWRT(0, + 'Unrecognised subkeyword of BREF---'//CVALUE(2)) ITEMP = 1 CALL ERRWRT(0,' Refine isotropic indivudal B-factors') ENDIF ITK = ITK+1 ELSEIF(CVALUE(ITK).EQ.'METH') THEN ITK = ITK+1 SOLVMIN = CVALUE(ITK)(1:4) IF(SOLVMIN.NE.'CGMA'.AND.SOLVMIN.NE.'CGRA'.AND. + SOLVMIN.NE.'CDIR') THEN CALL ERRWRT(0,' Unknown method:'//SOLVMIN// + ' reset to CGMA') SOLVMIN = 'CGMA' ENDIF ITK = ITK+1 ELSEIF(CVALUE(ITK).EQ.'BFGS') THEN ITK = ITK + 1 BFGS_FLAG = .TRUE. LINE_SEARCH_FLAG = .TRUE. WRITE(*,*)'In BFGS keywrod' ELSEIF(CVALUE(ITK).EQ.'LINE') THEN ITK = ITK + 1 LINE_SEARCH_FLAG = .TRUE. ELSEIF(CVALUE(ITK).EQ.'NEST') THEN ITK = ITK+1 CALL GTNINT(ITK,1,NESTIM,NTOK,ITYP,FVALUE) ITK = ITK+1 ELSEIF(CVALUE(ITK).EQ.'WTXR'.OR.CVALUE(ITK).EQ.'SIGM') THEN CALL ERRWRT(-1,'This is an out of date weighting scheme') CALL ERRWRT(-1,'Use WEIGht MATRix instead') CALL ERRWRT(-1,'Starting value for is 0.5') CALL ERRWRT + (1,'I suspect you are using an old script with a new version') ELSEIF(CVALUE(ITK).EQ.'PHAS') THEN ITK = ITK + 1 CALL READ_PHFACTORS(NTOK,ITK,CVALUE,ITYP,FVALUE) ELSEIF(CVALUE(ITK).EQ.'TLSR') THEN ITK = ITK + 1 MODE = 'TLSR' REFID = 'UNRE' ELSEIF(CVALUE(ITK).EQ.'TLSC') THEN ITK = ITK + 1 IF(ITK.GE.NTOK) & CALL GTNINT(ITK,1,NTLS_CYCLE,NTOK,ITYP,FVALUE) IF(ITK.LE.NTOK) THEN CALL GTNINT(ITK,1,NTLS_CYCLE,NTOK,ITYP,FVALUE) ITK = ITK + 1 ENDIF ELSEIF(CVALUE(ITK)(1:4).EQ.'XNON') THEN ITK = ITK + 1 IF(CVALUE(ITK)(1:3).EQ.'NO') THEN XNONDIAG_FLAG = .FALSE. ELSE XNONDIAG_FLAG = .TRUE. ENDIF ITK = ITK + 1 ELSEIF(CVALUE(ITK)(1:4).EQ.'EXCL') THEN ITK = ITK + 1 IF(CVALUE(ITK)(1:3).EQ.'ALL') THEN ITK = ITK + 1 EXCL_REFI_FLAG = .TRUE. CALL READ_FROMTO(NTOK,ITK,CVALUE,ITYP,FVALUE,IFIRST, & ILAST,CHNID) EXCL_REFI_NUM = EXCL_REFI_NUM + 1 if(excl_refi_num.gt.max_excl_refi) then write(*,*)' Too many exclusions from refinement ' write(*,*)' Maximum exclusions allowed (refi_flags.fh) ', & MAX_EXCL_REFI call errwrt(1,'Too many exclusions') endif EXCL_REFI_TYPE(EXCL_REFI_NUM) = 'ALL' EXCL_REFI_BEGIN(EXCL_REFI_NUM) = IFIRST EXCL_REFI_END(EXCL_REFI_NUM) = ILAST EXCL_REFI_CHN(EXCL_REFI_NUM) = CHNID ENDIF ELSE CALL ERRWRT(-1,' Unknown subkeyword of REFI ') CALL ERRWRT(-1,' ????? '//CVALUE(ITK)//' ????? ') IERROR = IERROR + 1 ITK = ITK+1 ENDIF IF(ITK.GE.NTOK) RETURN ENDDO RETURN END C SUBROUTINE MAKE_REST_PARAMS(NTOK,ITOK,LINE,IBEG,IEND,ITYP,FVALUE, & CVALUE,IERROR) IMPLICIT NONE INCLUDE 'makecif.fh' INTEGER NTOK,ITOK,IERROR INTEGER IBEG(*),IEND(*),ITYP(*) REAL FVALUE(*) CHARACTER LINE*(*),CVALUE(*)*4 C INTEGER ITK C IERROR = 0 DO ITK = ITOK,NTOK,2 IF(CVALUE(ITK).EQ.'HYDR') THEN MAKE_HFLAG = 'A' IF(ITK+1.LE.NTOK) THEN IF(CVALUE(ITK+1)(1:1).EQ.'Y'.OR.CVALUE(ITK+1)(1:1).EQ.'N'.OR. & CVALUE(ITK+1)(1:1).EQ.'A') THEN MAKE_HFLAG = CVALUE(ITK+1)(1:1) ELSE IERROR = IERROR + 1 CALL ERRWRT(0, & 'Wrong option for hydrogen generations '//CVALUE(ITK+1)) CALL ERRWRT(0,'A, Y or N are allowed') ENDIF ENDIF ELSEIF(CVALUE(ITK).EQ.'HOUT') THEN MAKE_HFLAG_O = 'N' IF(ITK+1.LE.NTOK) THEN MAKE_HFLAG_O = CVALUE(ITK+1)(1:1) ENDIF ELSEIF(CVALUE(ITK).EQ.'VALU') THEN MAKE_NEWL_VALUE_FLAG = 'N' IF(ITK+1.LE.NTOK) THEN IF(CVALUE(ITK+1)(1:1).EQ.'C') MAKE_NEWL_VALUE_FLAG = 'Y' ENDIF ELSEIF(CVALUE(ITK).EQ.'CHEC') THEN IF(CVALUE(ITK+1).EQ.'NONE'.OR.CVALUE(ITK+1)(1:1).EQ.'0') THEN MAKE_CHECK = '0' ELSEIF(CVALUE(ITK+1).EQ.'LIGA'.OR. & CVALUE(ITK+1)(1:1).EQ.'N') THEN MAKE_CHECK = 'N' ELSEIF(CVALUE(ITK+1)(1:3).EQ.'ALL'.OR. & CVALUE(ITK+1)(1:1).EQ.'Y') THEN MAKE_CHECK = 'Y' ELSE CALL ERRWRT(0,'Wrong option of MAKE CHECK') CALL ERRWRT(0,'Possible options are NONE/LIGAnd/ALL') ENDIF ELSEIF(CVALUE(ITK).EQ.'NEWL') THEN IF(ITK+1.LE.NTOK) THEN IF(CVALUE(ITK+1)(1:1).EQ.'E') MAKE_LIGAND_LEVEL_FLAG='H' ENDIF ELSEIF(CVALUE(ITK).EQ.'LIBR') THEN MAKE_FILE_LIB2 = LINE(IBEG(ITK+1):IEND(ITK+1)) ELSEIF(CVALUE(ITK).EQ.'SPEC') THEN MAKE_CHECK_SPEC = 'N' IF(ITK+1.LE.NTOK) THEN IF(CVALUE(ITK+1)(1:1).EQ.'Y'.OR. & CVALUE(ITK+1)(1:1).EQ.'N') THEN MAKE_CHECK_SPEC = CVALUE(ITK+1)(1:1) ELSE IERROR = IERROR + 1 CALL ERRWRT(0, & 'Wrong option for special positions '//CVALUE(ITK+1)) CALL ERRWRT(0,'Y or N are allowed') ENDIF ENDIF ELSEIF(CVALUE(ITK).EQ.'BUIL') THEN MAKE_RFLAG = 'N' IF(ITK+1.LE.NTOK) THEN IF(CVALUE(ITK+1)(1:1).EQ.'Y'.OR. & CVALUE(ITK+1)(1:1).EQ.'N') THEN MAKE_RFLAG = CVALUE(ITK+1)(1:1) ELSE IERROR = IERROR + 1 CALL ERRWRT(0, & 'Wrong option for rebuilding absent atoms '//CVALUE(ITK+1)) CALL ERRWRT(0,'Y or N are allowed') ENDIF ENDIF ELSEIF(CVALUE(ITK).EQ.'FORM') THEN MAKE_FORM = 'U' IF(ITK+1.LE.NTOK) THEN IF(CVALUE(ITK+1)(1:1).EQ.'U'.OR. & CVALUE(ITK+1)(1:1).EQ.'F') THEN MAKE_FORM = CVALUE(ITK+1)(1:1) ELSE IERROR = IERROR + 1 CALL ERRWRT(0, & 'Wrong option for file formats '//CVALUE(ITK+1)) CALL ERRWRT(0,'U or F are allowed') ENDIF ENDIF ELSEIF(CVALUE(ITK).EQ.'PEPT') THEN MAKE_PEPT_FLAG = 'Y' IF(ITK+1.LE.NTOK) THEN IF(CVALUE(ITK+1)(1:1).EQ.'Y'.OR. & CVALUE(ITK+1)(1:1).EQ.'N') THEN MAKE_PEPT_FLAG = CVALUE(ITK+1)(1:1) ELSE IERROR = IERROR + 1 CALL ERRWRT(0, & 'Wrong option for peptide flag '//CVALUE(ITK+1)) CALL ERRWRT(0,'U or F are allowed') ENDIF ENDIF ELSEIF(CVALUE(ITK).EQ.'LINK') THEN MAKE_LNK_FLAG = 'Y' IF(ITK+1.LE.NTOK) THEN IF(CVALUE(ITK+1)(1:1).EQ.'Y'.OR. & CVALUE(ITK+1)(1:1).EQ.'N'.OR. & CVALUE(ITK+1)(1:1).EQ.'D'.OR. & CVALUE(ITK+1)(1:1).EQ.'0') THEN MAKE_LNK_FLAG = CVALUE(ITK+1)(1:1) ELSE IERROR = IERROR + 1 CALL ERRWRT(0, & 'Wrong option for link corretions '//CVALUE(ITK+1)) CALL ERRWRT(0,'Y, N, D or o are allowed') ENDIF ENDIF ELSEIF(CVALUE(ITK).EQ.'SUGA') THEN MAKE_SUGAR_FLAG = 'Y' IF(ITK+1.LE.NTOK) THEN IF(CVALUE(ITK+1)(1:1).EQ.'Y'.OR. & CVALUE(ITK+1)(1:1).EQ.'N'.OR. & CVALUE(ITK+1)(1:1).EQ.'D'.OR. & CVALUE(ITK+1)(1:1).EQ.'S') THEN MAKE_SUGAR_FLAG = CVALUE(ITK+1)(1:1) ELSE IERROR = IERROR + 1 CALL ERRWRT(0, & 'Wrong option for link corretions '//CVALUE(ITK+1)) CALL ERRWRT(0,'Y, N or D are allowed') ENDIF ENDIF ELSEIF(CVALUE(ITK).EQ.'CONN') THEN MAKE_CONN_FLAG = 'N' IF(ITK+1.LE.NTOK) THEN IF(CVALUE(ITK+1)(1:1).EQ.'Y'.OR. & CVALUE(ITK+1)(1:1).EQ.'N'.OR. & CVALUE(ITK+1)(1:1).EQ.'D'.OR. & CVALUE(ITK+1)(1:1).EQ.'0') THEN MAKE_CONN_FLAG = CVALUE(ITK+1)(1:1) ELSE IERROR = IERROR + 1 CALL ERRWRT(0, & 'Wrong option for connectivity corretions '//CVALUE(ITK+1)) CALL ERRWRT(0,'Y, N, D or 0 are allowed') ENDIF ENDIF ELSEIF(CVALUE(ITK).EQ.'SYMM') THEN MAKE_SYMM_FLAG = 'Y' IF(ITK+1.LE.NTOK) THEN IF(CVALUE(ITK+1)(1:1).EQ.'Y'.OR. & CVALUE(ITK+1)(1:1).EQ.'N'.OR. & CVALUE(ITK+1)(1:1).EQ.'C') THEN MAKE_SYMM_FLAG = CVALUE(ITK+1)(1:1) ELSE IERROR = IERROR + 1 CALL ERRWRT(0, & 'Wrong option for bonds between symmetric atoms ' & //CVALUE(ITK+1)) CALL ERRWRT(0,'Y, N or C are allowed') ENDIF ENDIF ELSEIF(CVALUE(ITK).EQ.'CHAI') THEN MAKE_CHAIN_FLAG = 'Y' IF(ITK+1.LE.NTOK) THEN IF(CVALUE(ITK+1)(1:1).EQ.'Y'.OR. & CVALUE(ITK+1)(1:1).EQ.'N') THEN MAKE_CHAIN_FLAG = CVALUE(ITK+1)(1:1) ELSE IERROR = IERROR + 1 CALL ERRWRT(0, & 'Wrong option for chain correction ' & //CVALUE(ITK+1)) CALL ERRWRT(0,'Y or N are allowed') ENDIF ENDIF ELSEIF(CVALUE(ITK).EQ.'CISP') THEN MAKE_CIS_FLAG = 'Y' IF(ITK+1.LE.NTOK) THEN IF(CVALUE(ITK+1)(1:1).EQ.'Y'.OR. & CVALUE(ITK+1)(1:1).EQ.'N') THEN MAKE_CIS_FLAG = CVALUE(ITK+1)(1:1) ELSE IERROR = IERROR + 1 CALL ERRWRT(0, & 'Wrong option for cis/trans correction ' & //CVALUE(ITK+1)) CALL ERRWRT(0,'Y or N are allowed') ENDIF ENDIF ELSEIF(CVALUE(ITK)(1:2).EQ.'SS') THEN MAKE_SS_FLAG = 'Y' IF(ITK+1.LE.NTOK) THEN IF(CVALUE(ITK+1)(1:1).EQ.'Y'.OR. & CVALUE(ITK+1)(1:1).EQ.'D'.OR. & CVALUE(ITK+1)(1:1).EQ.'N') THEN MAKE_SS_FLAG = CVALUE(ITK+1)(1:1) ELSE IERROR = IERROR + 1 CALL ERRWRT(0, & 'Wrong option for SSbridge correction ' & //CVALUE(ITK+1)) CALL ERRWRT(0,'Y, N or D are allowed') ENDIF ENDIF ELSEIF(CVALUE(ITK).EQ.'SDMI') THEN MAKE_DMIN_SPEC = 0.5 IF(ITYP(ITK+1).EQ.2) THEN CALL GTNREA(ITK+1,1,MAKE_DMIN_SPEC,NTOK,ITYP,FVALUE) IF(MAKE_DMIN_SPEC.LT.0.0) MAKE_DMIN_SPEC = 0.0 ELSE CALL ERRWRT(0,'Wrong option for special position check') CALL ERRWRT(0,'Only number is allowed') IERROR = IERROR + 1 ENDIF ELSEIF(CVALUE(ITK).EQ.'EXIT') THEN IF(ITK.LE.NTOK) THEN MAKE_EXIT = 'Y' ELSE MAKE_EXIT = 'N' IF(CVALUE(ITK+1)(1:1).EQ.'Y') MAKE_EXIT = 'Y' ENDIF ELSE CALL ERRWRT(0,'Wrong option for make restraints ' & //CVALUE(ITK)) IERROR = IERROR + 1 RETURN ENDIF ENDDO RETURN END C SUBROUTINE MTZ_PARAMS(LABIN_C,LABOUT_C,IERROR) C C---Reads relevant keywords for mtz file. Opens and reads C---some info from mtz file. IMPLICIT NONE INCLUDE 'refi_flags.fh' INCLUDE 'celsym.fh' INCLUDE 'agreem.fh' INCLUDE 'weights.fh' INCLUDE 'vitals.fh' INCLUDE 'const.fh' include 'map_params.fh' CHARACTER LABIN_C*(*),LABOUT_C*(*) INTEGER IERROR INTEGER MPARS PARAMETER (MPARS = 200) INTEGER MCOLS PARAMETER (MCOLS = 200) INTEGER IBEG(MPARS),IEND(MPARS),IDEC(MPARS),ITYP(MPARS) REAL FVALUE(MPARS) CHARACTER CVALUE(MPARS)*4 C CHARACTER LaueGroupName*10,Clabs(Mcols)*30,Ctyps(Mcols)*1 INTEGER NLPRGI,NLPRGO INTEGER LOOKUP(MCOLS) COMMON /MTZRD/NLPRGI,NLPRGO,LOOKUP CHARACTER LSPRGI(MCOLS)*30,CTPRGI(MCOLS)*1,LSPRGO(16)*30, & CTPRGO(16)*1 COMMON /MTZRDC/LSPRGO,CTPRGO CHARACTER LSUSRJ(MCOLS)*30 INTEGER ILMAX,ILPRGO,NFPART,NAPART,ITOK,IP,NTOK,I,J,IS INTEGER NumLaueSymm,JDO115,MTZIN,MTZOUT,IFAIL,NCOL,ILAB INTEGER IPRINT REAL SSTL,SMN,SMX REAL RRR(3,3,6),CELMTZ(6),CELL_T(6) CHARACTER KEY*4 CHARACTER LINE1*128 LOGICAL LPRINT,LEND C C----Harvesting stuff INTEGER MSETS PARAMETER (MSETS = MCOLS) INTEGER NDATASETS,ISETS(MSETS),ISET,CSETID(MCOLS),CSETOUT(MCOLS), + SETID integer ilprgo_start REAL DATCELL,DATWAVE CHARACTER*64 PNAME,XNAME,DNAME,PNAME_OUT,XNAME_OUT,DNAME_OUT COMMON /MTZSET/ NDATASETS,PNAME(MSETS),XNAME(MSETS),DNAME(MSETS), + PNAME_OUT(MCOLS),XNAME_OUT(MCOLS),DNAME_OUT(MCOLS), + DATCELL(6,MSETS),DATWAVE(MSETS) C C---Data block DATA NLPRGI,LSPRGI/34,'H','K','L','FP','SIGFP','FREE', + 'FPART1','PHIP1','FPART2','PHIP2','FPART3','PHIP3', + 'HLA','HLB','HLC','HLD','FOM','PHIB', + 182*' '/ DATA CTPRGI/'H','H','H','F','Q','I','F','P','F','P','F','P', + 'A','A','A','A','W','P', + 182*' '/ DATA LookUp/-1,-1,-1,-1,-1,195*0/ DATA NLPRGO,LSPRGO/0,'H','K','L','FP','SIGFP','FREE','FC','PHIC', + 'FWT','PHWT','DELFWT','PHDELWT','FOM','PHCOMB',' ',' '/ DATA CTPRGO/'H','H','H','F','Q','I','F','P','F','P','F','P','W', + 'P',' ',' '/ C do i = 1,6 celmtz(i) = 0.0 enddo MTZIN = 1 NTOK = MPARS LPRINT = .FALSE. IF(LABIN_C.NE.' ') THEN CALL PARSER(KEY,LABIN_C,IBEG,IEND,ITYP,FVALUE,CVALUE,IDEC,NTOK, & LEND,LPRINT) CALL LKYIN(1,LSPRGI,NLPRGI,NTOK,LABIN_C,IBEG,IEND) ITOK = 2 CALL LKYSET(LSPRGI,NLPRGI,LSUSRJ,LOOKUP,ITOK,NTOK,LABIN_C,IBEG, & IEND) ILMAX = 5 NFPART = 0 NAPART = 0 NPART = 0 NSCPART = 0 c c---Free_R factor IF (LOOKUP(6).NE.0) THEN FREER_FLAG = .TRUE. C Has Free R exclusion been set to something other than 0 IF ( LFreeRexcludeVal .EQ.-999) LFreeRexcludeVal = 0 ILMAX = ILMAX + 1 END IF c c---Fpart input? DO IP=1,NMAXPART IF (LOOKUP(5+2*IP).NE.0.AND.LOOKUP(5+2*IP+1).NE.0) THEN FPART_FLAG = .TRUE. NPART = NPART + 1 IF( ISCPART(IP) .NE.0) NSCPART = NSCPART + 1 C But this is not output - overwritten by map coefficients ILMAX = ILMAX + 2 ELSEIF(LOOKUP(5+2*IP).NE.0.AND.LOOKUP(5+2*IP+1).EQ.0.OR. + LOOKUP(5+2*IP).EQ.0.AND.LOOKUP(5+2*IP+1).NE.0) THEN WRITE(LINE1,'(A,I5,A)') + ' Amplitude or phases for partial ',IP, + ' structure has not been assigned. Ignore it' CALL ERRWRT(0,LINE1) LOOKUP(5+2*IP) = 0 LOOKUP(6+2*IP) = 0 END IF ENDDO IF(LOOKUP(6+2*NMAXPART+1).NE.0.AND. + LOOKUP(6+2*NMAXPART+2).NE.0) THEN MIR_FLAG = .TRUE. ILMAX = ILMAX + 2 ELSEIF(LOOKUP(6+2*NMAXPART+1).EQ.0.AND. + LOOKUP(6+2*NMAXPART+2).NE.0.OR. + LOOKUP(6+2*NMAXPART+1).NE.0.AND. + LOOKUP(6+2*NMAXPART+2).EQ.0) THEN WRITE(LINE1,'(A)') + ' A or B for MIR/MAD has not been assigned. Ingore it' CALL ERRWRT(0,LINE1) ENDIF IF(MIR_FLAG.AND.LOOKUP(6+2*NMAXPART+3).NE.0.AND. + LOOKUP(6+2*NMAXPART+4).NE.0) THEN ILMAX = ILMAX + 2 ENDIF IF(LOOKUP(6+2*NMAXPART+5).NE.0.AND.LOOKUP(6+2*NMAXPART+6).NE.0) + THEN PHASE_FLAG = .TRUE. ILMAX = ILMAX + 2 ELSEIF(LOOKUP(6+2*NMAXPART+5).EQ.0.AND. + LOOKUP(6+2*NMAXPART+6).NE.0) THEN PHASE_FLAG = .TRUE. ILMAX = ILMAX + 1 CALL ERRWRT(0, + 'Figure of merit of phases has not been assigned') CALL ERRWRT(0,'They will be assumed to be equal to 1.0') ENDIF ENDIF 500 CONTINUE LPRINT = .FALSE. IPRINT = 0 IFAIL = 0 CALL LROPEN(MTZIN,'HKLIN',IPRINT,IFAIL) IF(IFAIL.GT.0) CALL ERRWRT(1,' Reflection file ') CALL LRASSN(MTZIN,LSPRGI,NLPRGI,LOOKUP,CTPRGI) CALL LRCLAB(MTZIN,CLABS,CTYPS,NCOL) C Notify available space NDATASETS = MSETS CALL LRIDX(MTZIN,PNAME,XNAME,DNAME,ISETS, + DATCELL,DATWAVE,NDATASETS) C C---- Get dataset ID for column and match to dataset header info. IF (NDATASETS.GT.0) CALL LRCLID(MTZIN,CSETID,NCOL) C C---- Copy over FP SIGFP information for output if required LSPRGO(4) = CLABS(LookUp(4)) LSPRGO(5) = CLABS(LookUp(5)) CTPRGO(4) = CTYPS(LookUp(4)) CTPRGO(5) = CTYPS(LookUp(5)) IF (NDATASETS.GT.0) THEN CSETOUT(1) = CSETID(LookUp(1)) CSETOUT(2) = CSETID(LookUp(2)) CSETOUT(3) = CSETID(LookUp(3)) CSETOUT(4) = CSETID(LookUp(4)) CSETOUT(5) = CSETID(LookUp(5)) ENDIF C C---- Is FreeRFlag set ILPRGO = 14 IF (LookUp(6).NE.0) THEN LSPRGO(6) = CLABS(LookUp(6)) CTPRGO(6) = CTYPS(LookUp(6)) C The FreeRflag should belong to the base data set IF (NDATASETS.GT.0) CSETOUT(6) = CSETID(LookUp(1)) END IF C IF((.NOT.MIR_FLAG).AND.(.NOT.PHASE_FLAG)) THEN C C-----Knock off the PHICOMB label ILPRGO = ILPRGO-1 ENDIF C C---Add users coefficients. if(scale_map_calc.gt.0.0.or.scale_map_obs.gt.0.0) then ilprgo = ilprgo + 1 LSPRGO(ilprgo) = 'F_user' CTPRGO(ilprgo) = 'F' ilprgo = ilprgo + 1 LSPRGO(ilprgo) = 'PHI_user' CTPRGO(ilprgo) = 'P' endif NLPRGO = ILPRGO C C---- Move FC PHIC WWT DELFWT PHICOMB labels if No FreeRflag ilprgo_start = 7 IF (LookUp(6).EQ.0) THEN DO ILAB = 6,NLPRGO-1 LSPRGO(ILAB) = LSPRGO(ILAB+1) CTPRGO(ILAB) = CTPRGO(ILAB+1) ENDDO ILPRGO = ILPRGO-1 ilprgo_start = 6 END IF NLPRGO = ILPRGO C C Now for output if requested: File opened in SR oppro IF( LABOUT_C .NE. ' ') THEN MTZOUT = 2 C NLPRGO = ILPRGO C C----In case LSQ we have only 7 or 8 output labels IF(REFS.EQ.'LSQF') THEN NLPRGO = 8 IF(LookUp(6).EQ.0) NLPRGO = 7 ENDIF CALL PARSER(KEY,LABOUT_C,IBEG,IEND,ITYP,FVALUE,CVALUE,IDEC, & NTOK,LEND,.FALSE.) CALL LKYOUT(MTZOUT,LSPRGO,NLPRGO,NTOK,LABOUT_C,IBEG,IEND) END IF IF (NDATASETS.GT.0) THEN DO ILAB = ilprgo_start,NLPRGO C----All new columns inherit dataset of FP CSETOUT(ILAB) = CSETID(LookUp(4)) ENDDO DO JDO115 = 1,NLPRGO SETID = CSETOUT(JDO115) DO ISET = 1,NDATASETS IF (ISETS(ISET).EQ.SETID) THEN PNAME_OUT(JDO115) = PNAME(ISET) XNAME_OUT(JDO115) = XNAME(ISET) DNAME_OUT(JDO115) = DNAME(ISET) do i=1,6 celmtz(i) = datcell(i,iset) enddo END IF ENDDO ENDDO END IF CALL LRSORT(MTZIN,ISORT) c Cell is selected from datasets, see above. Just use lrcell in case c no dataset information. if (celmtz(1).eq.0.0) then call lrcell(mtzin,celmtz) endif C C---If cell dimensions are different keep old cells C---If there were no cells take new one) DO I=1,6 CELL_T(I) = CELMTZ(I) ENDDO CALL CHECK_CELL(CELL_T,IERROR) IF(IERROR.EQ.3) THEN CALL ERRWRT(1,'Difference between cells from mtz and previous' & //' ones is more than 10% ' ) ENDIF CALL LSTRSL(MTZIN,CELMTZ(1),CELMTZ(2),CELMTZ(3), + CELMTZ(4),CELMTZ(5),CELMTZ(6)) C C Return CELL volume, and reciprocal cell for celsym.fh DO I=1,6 CELL_T(I) = CELL(I) ENDDO IF(CELL(4).LE.5.0.AND.CELL(5).LE.5.0.AND.CELL(6).LE.5.0) THEN CELL_T(4) = CELL(4)*RTODEG CELL_T(5) = CELL(5)*RTODEG CELL_T(6) = CELL(6)*RTODEG ENDIF CALL RBFRO1(CELL_T,VOLUME,RRR) CALL RBRCEL(RCELL,RVOL) C C---Read resolution CALL LRRSOL(MTZIN,SMN,SMX) SMN = SQRT(SMN)/2.0 SMX = SQRT(SMX)/2.0 IF(STLMIN.LE.0.0) STLMIN = SMN IF(STLMIN.LT.SMN) STLMIN = SMN IF(STLMAX.LE.0.0) STLMAX = SMX IF(STLMAX.GT.SMX) STLMAX = SMX C Scaling resolution: if not set on data line use full resolution range IF(SMINS.EQ.0.04 .AND. SMAXS .EQ.1.0) THEN SMINS = STLMIN SMAXS = STLMAX END IF C If a Range set for analysis, work out the number of bins now. SSTL = 4.0*STLMAX*STLMAX IF(RANGE.LT.-0.5) THEN RANGE = SSTL/NBIN END IF C C---Read symmetry and check against old symmetry. MTZ symmetry has C---highest priorety ISPNO = 1 LPRINT = .FALSE. CALL LRSYMI(MTZIN,NumPrimSymm,Ltype,NumSpaceGroup, + SpaceGroupName,PointGroupName) CALL LRSYMM(MTZIN,NumSymmetry,RealSymmMatrx) CALL PGDEFN(PointGroupName,NumPrimSymm,NumSymmetry, + RealSymmMatrx,LPRINT) CALL PGNLAU(PointGroupName,NumLaueSymm,LaueGroupName) C C---- Now set up the extinction check for soutfC CALL EPSLN(NumSymmetry, + NumPrimSymm, + RealSymmMatrx, + 0) CALL CENTRIC(NumSymmetry, + RealSymmMatrx, + 0) NSMULT = NumSymmetry/NumPrimSymm C C---Compare symmetry IF(ISPNO.GT.1) THEN IF(ISPNO.NE.NumSpaceGroup) THEN CALL ERRWRT(0,'Space group from mtz is different ') ENDIF ELSE DO IS=1,NumSymmetry DO I=1,3 DO J=1,3 ROT(I,J,IS) = RealSymmMatrx(I,J,IS) ENDDO TR(I,IS) = RealSymmMatrx(I,4,IS) ENDDO ENDDO NSYM = NumSymmetry ISPNO = NumSpaceGroup END IF CALL TKNONCUB RETURN END C SUBROUTINE NCSR_PARAMS(NTOK,ITOK_IN,IBEG,IEND,ITYP,FVALUE,CVALUE, & IERROR) C C---Reads relevant keywords for NCS restraints IMPLICIT NONE INCLUDE 'ncs_rest.fh' INCLUDE 'weights.fh' INTEGER IERROR,ITOK_IN INTEGER INCS INTEGER IBEG(*),IEND(*),ITYP(*) REAL FVALUE(*) CHARACTER CVALUE(*)*4 INTEGER NTOK,ITK,ITK1,ITK2,ICHAIN,NCS_FIRST,NCS_LAST, & NCS_ICODE_L,NCS_N_CHAIN_T,NCS_SPAN_T,III CHARACTER LINE*132 C IERROR = 0 C INCS = NUMBER_NCSR C C IF(NTOK.LE.1) RETURN C C---Chekck and take if following fields are relevant for the weighting ITK = ITOK_IN IF(ITYP(ITK).EQ.2.AND.ITK.LE.NTOK) THEN CALL GTNREA(ITK,1,WSSKAL,NTOK,ITYP,FVALUE) ITK = ITK + 1 ELSE GOTO 500 ENDIF IF(ITYP(ITK).EQ.2.AND.ITK.LE.NTOK) THEN CALL GTNREA(ITK,1,SIGS(1),NTOK,ITYP,FVALUE) ITK = ITK + 1 ELSE GOTO 500 ENDIF IF(ITYP(ITK).EQ.2.AND.ITK.LE.NTOK) THEN CALL GTNREA(ITK,1,SIGS(2),NTOK,ITYP,FVALUE) ITK = ITK + 1 ELSE GOTO 500 ENDIF IF(ITYP(ITK).EQ.2.AND.ITK.LE.NTOK) THEN CALL GTNREA(ITK,1,SIGS(3),NTOK,ITYP,FVALUE) ITK = ITK + 1 ELSE GOTO 500 ENDIF IF(ITYP(ITK).EQ.2.AND.ITK.LE.NTOK) THEN CALL GTNREA(ITK,1,SIGS(4),NTOK,ITYP,FVALUE) ITK = ITK + 1 ELSE GOTO 500 ENDIF IF(ITYP(ITK).EQ.2.AND.ITK.LE.NTOK) THEN CALL GTNREA(ITK,1,SIGS(5),NTOK,ITYP,FVALUE) ITK = ITK + 1 ELSE GOTO 500 ENDIF IF(ITYP(ITK).EQ.2.AND.ITK.LE.NTOK) THEN CALL GTNREA(ITK,1,SIGS(6),NTOK,ITYP,FVALUE) ITK = ITK + 1 ELSE GOTO 500 ENDIF C 500 CONTINUE IF(ITK.GT.NTOK-1) RETURN C C---First check if we have number of ncs chains. It is copulsory DO ITK1=ITK,NTOK-1 IF(CVALUE(ITK1).EQ.'NCHA') THEN IF(ITYP(ITK1+1).EQ.2) THEN CALL GTNINT(ITK1+1,1,NCS_N_CHAIN_T,NTOK,ITYP,FVALUE) IF(NCS_N_CHAIN_T.LE.1.OR. & NCS_N_CHAIN_T.GT.MAX_NCS_CHAIN) THEN CALL ERRWRT(-1, & 'Number of NCS chains is out of allowed range') CALL ERRWRT(-1,'No NCS for these chains will be used') WRITE(LINE,'(A,I5)')'Allowed range is from 2 to ', & MAX_NCS_CHAIN CALL ERRWRT(-1,LINE) CALL ERRWRT(-1,' ') GOTO 900 ENDIF INCS = INCS + 1 IF(INCS.GT.MAX_NCS) THEN CALL ERRWRT(-1,'Too many NCS restraints') GOTO 900 ENDIF NCS_N_CHAIN(INCS) = NCS_N_CHAIN_T GOTO 700 ENDIF ENDIF ENDDO CALL ERRWRT(-1, & 'Number of chains for NCS have not been defined') CALL ERRWRT(-1,'No NCS will be used for these chains') GOTO 900 700 CONTINUe C c---Now find chain names. This is compulsory DO ITK1=ITK,NTOK IF(CVALUE(ITK1).EQ.'CHAI'.OR.CVALUE(ITK1).EQ.'CHNI') THEN IF(ITK+NCS_N_CHAIN(INCS).GT.NTOK) THEN CALL ERRWRT(-1,'Not enough information for NCS chains') WRITE(LINE,'(A,I5)') & 'Number of chain names program expects is ', & NCS_N_CHAIN(INCS) CALL ERRWRT(-1,LINE) CALL ERRWRT(-1,'No NCS for these chains will be used') GOTO 900 ENDIF ICHAIN = 1 DO ITK2=ITK1+1,ITK1+NCS_N_CHAIN(INCS) NCS_CHAINS(ICHAIN,INCS) = CVALUE(ITK2) ICHAIN = ICHAIN + 1 ENDDO GOTO 750 ENDIF ENDDO CALL ERRWRT(-1,'Chain names for NCS have not been defined') CALL ERRWRT(-1,'No NCS will be used') GOTO 900 750 CONTINUE C c---Now find spans. It is not compulsory. Default is NSPAN = 1. C---All residues in the given chains and weighting 1 NCS_SPANS(INCS) = 1 NCS_IRES_FIRST(1,INCS) = -9999 NCS_IRES_LAST(1,INCS) = 99999 DO ITK1 = ITK,NTOK-3 IF(CVALUE(ITK1).EQ.'NSPA') THEN IF(ITYP(ITK1+1).EQ.2) THEN CALL GTNINT(ITK1+1,1,NCS_SPAN_T,NTOK,ITYP,FVALUE) IF(NCS_SPAN_T.GT.MAX_NCS_SPAN) THEN CALL ERRWRT(-1,'Too many spans for this NCS') WRITE(LINE,'(A,I5)')'Maximum allowed is', & MAX_NCS_SPAN CALL ERRWRT(-1,LINE) CALL ERRWRT(-1, & 'No NCS will be used for these chains') GOTO 900 ENDIF IF(NCS_SPAN_T.LE.0) THEN NCS_SPANS(INCS) = 1 NCS_IRES_FIRST(1,INCS) = -99999 NCS_IRES_LAST(1,INCS) = 99999 GOTO 800 ELSE NCS_SPANS(INCS) = NCS_SPAN_T ENDIF IF(ITK1+3*NCS_SPANS(INCS).GT.NTOK) THEN CALL ERRWRT(-1, & 'Not enough information for NCS spans') WRITE(LINE,'(A,I5)')'Number of expected spans is', & NCS_SPANS(INCS) CALL ERRWRT(-1,LINE) CALL ERRWRT(-1, & 'No NCS will be used for these chains') GOTO 900 ENDIF ITK2 = ITK1+2 DO III=1,NCS_SPANS(INCS) CALL GTNINT(ITK2,1,NCS_FIRST,NTOK,ITYP,FVALUE) ITK2 = ITK2 + 1 CALL GTNINT(ITK2,1,NCS_LAST,NTOK,ITYP,FVALUE) IF(NCS_FIRST.LE.NCS_LAST) THEN NCS_IRES_FIRST(III,INCS) = NCS_FIRST NCS_IRES_LAST(III,INCS) = NCS_LAST ELSE NCS_IRES_FIRST(III,INCS) = NCS_LAST NCS_IRES_LAST(III,INCS) = NCS_FIRST ENDIF ITK2 = ITK2 + 1 CALL GTNINT(ITK2,1,NCS_ICODE_L,NTOK,ITYP,FVALUE) IF(NCS_ICODE_L.LE.0.OR.NCS_ICODE_L.GT.6) NCS_ICODE_L = 1 NCS_ICODE(III,INCS) = NCS_ICODE_L ITK2 = ITK2 + 1 ENDDO ENDIF ENDIF ENDDO 800 CONTINUE GOTO 910 900 CONTINUE CALL ERRWRT(1, & 'Problem with keywords relevant to the NCS restraints') 910 CONTINUE NUMBER_NCSR = INCS RETURN END C SUBROUTINE NCSC_PARAMS(NTOK,ITOK_IN,IBEG,IEND,ITYP,FVALUE,CVALUE, & IERROR) C C---Reads relevant keywords for NCS restraints IMPLICIT NONE INCLUDE 'ncs_rest.fh' INCLUDE 'weights.fh' INTEGER IERROR,ITOK_IN INTEGER INCS INTEGER IBEG(*),IEND(*),ITYP(*) REAL FVALUE(*) CHARACTER CVALUE(*)*4 INTEGER NTOK,ITK,ITK1,ITK2,ICHAIN,NCSC_FIRST,NCSC_LAST, & NCSC_ICODE_L,NCSC_N_CHAIN_T,NCSC_SPAN_T,III CHARACTER LINE*132 C IERROR = 0 C ITK = ITOK_IN INCS = NUMBER_NCSC C IF(NTOK.LE.1) RETURN C 500 CONTINUE IF(ITK.GT.NTOK-1) RETURN C C---First check if we have number of ncs chains. It is copulsory DO ITK1=ITK,NTOK-1 IF(CVALUE(ITK1).EQ.'NCHA') THEN IF(ITYP(ITK1+1).EQ.2) THEN CALL GTNINT(ITK1+1,1,NCSC_N_CHAIN_T,NTOK,ITYP,FVALUE) IF(NCSC_N_CHAIN_T.LE.1.OR. & NCSC_N_CHAIN_T.GT.MAX_NCSC_CHAIN) THEN CALL ERRWRT(-1, & 'Number of NCS chains is out of allowed range') CALL ERRWRT(-1,'No NCS for these chains will be used') WRITE(LINE,'(A,I5)')'Allowed range is from 2 to ', & MAX_NCSC_CHAIN CALL ERRWRT(-1,LINE) CALL ERRWRT(-1,' ') GOTO 900 ENDIF INCS = INCS + 1 IF(INCS.GT.MAX_NCSC) THEN CALL ERRWRT(-1,'Too many NCS restraints') GOTO 900 ENDIF NCSC_N_CHAIN(INCS) = NCSC_N_CHAIN_T GOTO 700 ENDIF ENDIF ENDDO CALL ERRWRT(-1, & 'Number of chains for NCS have not been defined') CALL ERRWRT(-1,'No NCS will be used for these chains') GOTO 900 700 CONTINUe C c---Now find chain names. This is compulsory DO ITK1=ITK,NTOK IF(CVALUE(ITK1).EQ.'CHAI'.OR.CVALUE(ITK1).EQ.'CHNI') THEN IF(ITK+NCSC_N_CHAIN(INCS).GT.NTOK) THEN CALL ERRWRT(-1,'Not enough information for NCS chains') WRITE(LINE,'(A,I5)') & 'Number of chain names program expects is ', & NCSC_N_CHAIN(INCS) CALL ERRWRT(-1,LINE) CALL ERRWRT(-1,'No NCS for these chains will be used') GOTO 900 ENDIF ICHAIN = 1 DO ITK2=ITK1+1,ITK1+NCSC_N_CHAIN(INCS) NCSC_CHAINS(ICHAIN,INCS) = CVALUE(ITK2) ICHAIN = ICHAIN + 1 ENDDO GOTO 750 ENDIF ENDDO CALL ERRWRT(-1,'Chain names for NCSC have not been defined') CALL ERRWRT(-1,'No NCS will be used') GOTO 900 750 CONTINUE C c---Now find spans. It is not compulsory. Default is NSPAN = 1. C---All residues in the given chains and weighting 1 NCSC_SPANS(INCS) = 1 NCSC_IRES_FIRST(1,INCS) = -9999 NCSC_IRES_LAST(1,INCS) = 99999 DO ITK1 = ITK,NTOK-3 IF(CVALUE(ITK1).EQ.'NSPA') THEN IF(ITYP(ITK1+1).EQ.2) THEN CALL GTNINT(ITK1+1,1,NCSC_SPAN_T,NTOK,ITYP,FVALUE) IF(NCSC_SPAN_T.GT.MAX_NCSC_SPAN) THEN CALL ERRWRT(-1,'Too many spans for this NCS') WRITE(LINE,'(A,I5)')'Maximum allowed is', & MAX_NCSC_SPAN CALL ERRWRT(-1,LINE) CALL ERRWRT(-1, & 'No NCS will be used for these chains') GOTO 900 ENDIF IF(NCSC_SPAN_T.LE.0) THEN NCSC_SPANS(INCS) = 1 NCSC_IRES_FIRST(1,INCS) = -99999 NCSC_IRES_LAST(1,INCS) = 99999 GOTO 800 ELSE NCSC_SPANS(INCS) = NCSC_SPAN_T ENDIF IF(ITK1+3*NCSC_SPANS(INCS).GT.NTOK) THEN CALL ERRWRT(-1, & 'Not enough information for NCS spans') WRITE(LINE,'(A,I5)')'Number of expected spans is', & NCSC_SPANS(INCS) CALL ERRWRT(-1,LINE) CALL ERRWRT(-1, & 'No NCS will be used for these chains') GOTO 900 ENDIF ITK2 = ITK1+2 DO III=1,NCSC_SPANS(INCS) CALL GTNINT(ITK2,1,NCSC_FIRST,NTOK,ITYP,FVALUE) ITK2 = ITK2 + 1 CALL GTNINT(ITK2,1,NCSC_LAST,NTOK,ITYP,FVALUE) IF(NCSC_FIRST.LE.NCSC_LAST) THEN NCSC_IRES_FIRST(III,INCS) = NCSC_FIRST NCSC_IRES_LAST(III,INCS) = NCSC_LAST ELSE NCSC_IRES_FIRST(III,INCS) = NCSC_LAST NCSC_IRES_LAST(III,INCS) = NCSC_FIRST ENDIF ITK2 = ITK2 + 1 ENDDO ENDIF ENDIF ENDDO 800 CONTINUE GOTO 910 900 CONTINUE CALL ERRWRT(1, & 'Problem with keywords relevant to the NCS constraints') 910 CONTINUE NUMBER_NCSC = INCS WRITE(*,*)NUMBER_NCSC RETURN END C SUBROUTINE READ_PHFACTORS(NTOK,ITK,CVALUE,ITYP,FVALUE) C C---Reads factors for phased refinement, e.g. bluring factors C C---Blurring factor will be applied as following C C(HLANEW,,) = (HLA,,)*PHAS_BLUR_SCAL*EXP(-(SIN(theta)/lam)**2*PHAS_BLUR_BVAL C INCLUDE 'refi_flags.fh' REAL FVALUE(*) INTEGER NTOK,ITK INTEGER ITYP(*) CHARACTER CVALUE(*)*4 IF(ITK.GT.NTOK) THEN PHAS_BLUR_SCAL = 1.0 PHAS_BLUR_BVAL = 0.0 ELSE 10 CONTINUE C C---Check for acceptable subkeywords. Now only blurring factors are available IF(CVALUE(ITK).NE.'SCBL'.AND.CVALUE(ITK).NE.'BBLU' + .AND.CVALUE(ITK+1).NE.'SIGM') GOTO 20 IF(CVALUE(ITK).EQ.'SCBL') THEN IF(ITK.GT.NTOK) GOTO 20 C C---Scale for blurring ITK = ITK + 1 IF(ITYP(ITK).EQ.2) THEN CALL GTNREA(ITK,1,PHAS_BLUR_SCAL,NTOK,ITYP,FVALUE) ITK = ITK + 1 ELSE PHAS_BLUR_SCAL = 1.0 ENDIF ELSEIF(CVALUE(ITK).EQ.'BBLU') THEN C C----Bvalue for blurring ITK = ITK+1 IF(ITK.GT.NTOK) GOTO 20 IF(ITYP(ITK).EQ.2) THEN CALL GTNREA(ITK,1,PHAS_BLUR_BVAL,NTOK,ITYP,FVALUE) ITK = ITK + 1 ELSE PHAS_BLUR_BVAL = 0.0 ENDIF ELSEIF(CVALUE(ITK).EQ.'SIGM') THEN C C---Include or not include in sigmaa calculation ITK = ITK + 1 IF(CVALUE(ITK).NE.'NO'.AND.CVALUE(ITK).NE.'YES') THEN PHASE_SIGMAA_FLAG=.TRUE. ITK = ITK + 1 ELSEIF(CVALUE(ITK).EQ.'YES') THEN PHASE_SIGMAA_FLAG=.TRUE. ITK = ITK + 1 ELSEIF(CVALUE(ITK).EQ.'NO') THEN PHASE_SIGMAA_FLAG=.FALSE. ITK = ITK + 1 ENDIF ENDIF GOTO 10 ENDIF 20 CONTINUE RETURN END SUBROUTINE + READ_RBODY_PARS(NERROR,NTOK,ITK,CVALUE,ITYP,FVALUE) C C---Reads parameters of rigid body and saves them in rigid_body.fh INCLUDE 'atom_com.fh' INCLUDE 'pls_incl.fh' INCLUDE 'rigid_body.fh' INCLUDE 'const.fh' CHARACTER CVALUE(*)*4 INTEGER ITYP(*) REAL FVALUE(*) C C---Local ariables INTEGER IFIRST,ILAST CHARACTER CHNID*1,LINE*80 C IGR = 0 IPIECE = 0 ITK = ITK + 1 10 CONTINUE IF(ITK.GT.NTOK) GOTO 999 IF(CVALUE(ITK).NE.'GROU'.AND.CVALUE(ITK).NE.'NCYC' + .AND.CVALUE(ITK).NE.'EXCL'.AND.CVALUE(ITK).NE.'WEIG' + .AND.CVALUE(ITK).NE.'PRIN') THEN NERROR = NERROR + 1 CALL ERRWRT(0,'Wrong subkeyword of RIGIdbody: '//CVALUE(ITK)) GOTO 999 ENDIF C IF(CVALUE(ITK).EQ.'GROU') THEN ITK = ITK + 1 C IF(ITYP(ITK).NE.2) THEN CALL + ERRWRT(0,'GROUp keyword should be followed by number') NERROR = NERROR + 1 GOTO 999 ENDIF C CALL GTNINT(ITK,1,IGROUP,NTOK,ITYP,FVALUE) IGR = IGROUP ITK = ITK + 1 20 CONTINUE IF(ITK.GE.NTOK) GOTO 999 C IF(CVALUE(ITK).NE.'FROM'.AND.CVALUE(ITK).NE.'WEIG'.AND. + CVALUE(ITK).NE.'EXCL'.AND.CVALUE(ITK).NE.'TRAN'.AND. + CVALUE(ITK).NE.'EULE') THEN NERROR = NERROR + 1 CALL ERRWRT(0, + 'Wrong subkeyword of RIGID GROUP '//CVALUE(ITK)) GOTO 999 C ELSEIF(CVALUE(ITK).EQ.'FROM') THEN CALL READ_FROMTO(NTOK,ITK,CVALUE,ITYP,FVALUE,IFIRST, + ILAST,CHNID) IDOMAIN_PIECES(IGR) = IDOMAIN_PIECES(IGR) + 1 C WRITE(LINE,'(A,3I10)') C + 'Maximum number of pieces per domain = ',MAXPIECES, C + IDOMAIN_PIECES(IGR),IGR C CALL ERRWRT(-1,' ') C CALL ERRWRT(-1,LINE) IF(IDOMAIN_PIECES(IGR).GT.MAXPIECES) THEN WRITE(LINE,'(A,3I10)') + 'Maximum number of pieces per domain = ',MAXPIECES, + IDOMAIN_PIECES(IGR),IGR CALL ERRWRT(-1,LINE) CALL ERRWRT(1,'Too many pieces for one domain') ENDIF IPIECE = IDOMAIN_PIECES(IGR) IDOMAIN_FROM(IPIECE,IGR) = IFIRST IDOMAIN_TO(IPIECE,IGR) = ILAST IDOMAIN_CHN(IPIECE,IGR) = CHNID IF(ITK.GE.NTOK) GOTO 999 GOTO 20 ELSEIF(CVALUE(ITK).EQ.'EXCL') THEN C C---Excluding criteria for this particular domain C ITK=ITK+1 IF(CVALUE(ITK).NE.'SCHA'.AND.CVALUE(ITK).NE.'MCHA'.AND. + CVALUE(ITK).NE.'NONE' ) THEN NERROR = NERROR + 1 CALL ERRWRT(0,'EXCL should be followed by MCHA or SCHA'// + ' NONE') ENDIF EXCLUDE_DOMAIN(IGR) = CVALUE(ITK) GOTO 20 ELSEIF(CVALUE(ITK).EQ.'WEIG') THEN C C---Weighting criteria for this particular domain ITK = ITK + 1 IF(CVALUE(ITK).NE.'SCHA'.AND.CVALUE(ITK).NE.'MCHA') THEN NERROR = NERROR + 1 CALL ERRWRT(0,'WEIG should be followed by MCHA or SCHA') GOTO 20 ENDIF WEIGHT_DOMAIN(IGR) = CVALUE(ITK) WEIGHT_DOMAIN_VALUE(IGR) = 1.0 IF(ITYP(ITK+1).EQ.2)THEN ITK = ITK + 1 CALL GTNREA(ITK,1,WEIGHT_TEMP,NTOK,ITYP,FVALUE) WEIGHT_DOMAIN_VALUE(IGR) = WEIGHT_TEMP ELSE CALL ERRWRT(0,'WEIG'//CVALUE(ITK)// + ' should be followed by a number') ENDIF GOTO 20 ELSEIF(CVALUE(ITK).EQ.'TRAN') THEN IF(ITYP(ITK+1).NE.2.AND.ITYP(ITK+2).NE.2 + .AND.ITYP(ITK+3).NE.3) THEN NERROR = NERROR + 1 CALL ERRWRT(0,'TRAN should be followed by 3 numbers') GOTO 20 ENDIF CALL GTNREA(ITK+1,1,TR_temp,NTOK,ITYP,FVALUE) TRANS_INIT_RIGID(1,IGR) = TR_temp CALL GTNREA(ITK+2,1,TR_temp,NTOK,ITYP,FVALUE) TRANS_INIT_RIGID(2,IGR) = TR_temp CALL GTNREA(ITK+3,1,TR_temp,NTOK,ITYP,FVALUE) TRANS_INIT_RIGID(3,IGR) = TR_temp ITK = ITK + 3 GOTO 20 ELSEIF(CVALUE(ITK).EQ.'EULE') THEN IF(ITYP(ITK+1).NE.2.AND.ITYP(ITK+2).NE.2 + .AND.ITYP(ITK+3).NE.3) THEN NERROR = NERROR + 1 CALL ERRWRT(0,'EULE should be followed by 3 numbers') GOTO 20 ENDIF CALL GTNREA(ITK+1,1,TR_temp,NTOK,ITYP,FVALUE) EULER_INIT_RIGID(1,IGR) = TR_temp*DEGTOR CALL GTNREA(ITK+2,1,TR_temp,NTOK,ITYP,FVALUE) EULER_INIT_RIGID(2,IGR) = TR_temp*DEGTOR CALL GTNREA(ITK+3,1,TR_temp,NTOK,ITYP,FVALUE) EULER_INIT_RIGID(3,IGR) = TR_temp*DEGTOR ITK = ITK + 3 GOTO 20 ENDIF GOTO 10 ELSEIF(CVALUE(ITK).EQ.'EXCL') THEN C c--Get overall exclusion criteria. Now only available options are schain GOTO 10 ELSEIF(CVALUE(ITK).EQ.'WEIG') THEN C C---Weighting criteria GOTO 10 ELSEIF(CVALUE(ITK).EQ.'NCYC') THEN ITK = ITK + 1 IF(ITK.LE.NTOK) THEN CALL GTNINT(ITK,1,NRIGID_CYCLE,NTOK,ITYP,FVALUE) ITK = ITK + 1 ELSE NERROR = NERROR+1 ENDIF GOTO 10 ELSEIF(CVALUE(ITK).EQ.'PRIN') THEN 800 CONTINUE ITK = ITK + 1 IF(ITK.LE.NTOK) THEN IF(CVALUE(ITK).EQ.'EULE') THEN EULER_PRINT_RIGID=.TRUE. ELSEIF(CVALUE(ITK).EQ.'MATR') THEN MATRIX_PRINT_RIGID=.TRUE. ELSE CALL ERRWRT(0,'Wrong subkeyword of RIGID PRIN') NERROR = NERROR + 1 ENDIF GOTO 800 ENDIF GOTO 10 ENDIF 999 CONTINUE RETURN C END C SUBROUTINE READ_FROMTO(NTOK,ITK,CVALUE,ITYP,FVALUE,IFIRST, + ILAST,CHNID) C C---Reads residue selection with a format C FROM TO C--keyword FROM should be taken before calling this routine. C INTEGER ITYP(*),IFIRST,ILAST,ITK,NTOK REAL FVALUE(*) CHARACTER CHNID*1 CHARACTER CVALUE(*)*4 C NERROR = 0 IFIRST = -1 ILAST = -1 ITK = ITK + 1 IF(ITK.GE.NTOK) NERROR = NERROR + 1 IF(ITYP(ITK).EQ.2) THEN CALL GTNINT(ITK,1,IFIRST,NTOK,ITYP,FVALUE) ITK = ITK + 1 CHNID = CVALUE(ITK)(1:1) ITK = ITK + 1 IF(ITK.LT.NTOK.AND.CVALUE(ITK).EQ.'TO') THEN ITK = ITK + 1 CALL GTNINT(ITK,1,ILAST,NTOK,ITYP,FVALUE) ITK = ITK + 2 ELSE NERROR = NERROR + 1 ENDIF ELSE NERROR = NERROR + 1 ENDIF C WRITE(6,'(/,A,2I10,A)')' IFIRST AND ILAST of CHAIN:', C + IFIRST,ILAST,CHNID IF(NERROR.GT.0) THEN CALL ERRWRT(-1,'Format for selection should be:') CALL ERRWRT(-1, + 'FROM TO ') CALL ERRWRT(1,'In residue selection') ENDIF RETURN END C SUBROUTINE FIND_CENTR_SYM(NumSymmetry,MaxSym,RealSymmMatrx, + IFACTOR,ERROR) C C---Finds maximum number of reflections for given HMAX,KMAX,LMAX and symmetry C---RealSymmMatrx(4,4,MaxSym) C REAL RealSymmMatrx(4,4,MaxSym) LOGICAL ERROR IFACTOR = 1 DO ISYM=1,NumSymmetry DET_SYM = RealSymmMatrx(1,1,ISYM)* + (RealSymmMatrx(2,2,ISYM)*RealSymmMatrx(3,3,ISYM) - + RealSymmMatrx(2,3,ISYM)*RealSymmMatrx(3,2,ISYM))- + RealSymmMatrx(1,2,ISYM)* + (RealSymmMatrx(2,1,ISYM)*RealSymmMatrx(3,3,ISYM) - + RealSymmMatrx(3,1,ISYM)*RealSymmMatrx(2,3,ISYM))+ + RealSymmMatrx(1,3,ISYM)* + (RealSymmMatrx(2,1,ISYM)*RealSymmMatrx(3,2,ISYM) - + RealSymmMatrx(3,1,ISYM)*RealSymmMatrx(2,2,ISYM)) IF(DET_SYM.LT.0.0) IFACTOR = 2 ENDDO RETURN END