************************************************************************ * MASTER MECHANISM - ROUTINE NAME : ckgrppt * * * * * * * PURPOSE : Check for misordered functionalities in parentheses * * next to each other in the group given as input. * * The functionalities in the group are sorted at the output * * * * INPUT: * * - locat : pointer of first string ")(" in group * * * * INPUT/OUTPUT: * * - group : the group that must be checked. * * * * * * ckgrppt checks the input "group" for misordered groups in * * parentheses next to each other. For group priority see "organic.h", * * where the priority invers TOP-DOWN. * * * * Do ensure full permutation of: C(X1)(X2)(X3) * * * * PTR21 PTR23 LNG3 * * | |____/___ * * C(..X1..)(..X2..)(..X3..) * * | | | | * * PTR11 PTR12 PTR32 PTR33 * * * ************************************************************************ SUBROUTINE ckgrppt(locat,group) IMPLICIT NONE INCLUDE 'general.h' INCLUDE 'organic.h' * input INTEGER,INTENT(in) :: locat * input/output CHARACTER(LEN=lgr),INTENT(out) :: group * internal: CHARACTER(LEN=lgr) :: tgroup CHARACTER(LEN=lgr) :: grp1, grp2, grp3 CHARACTER*3 :: grp(3) INTEGER :: ptr11, ptr12, ptr21 INTEGER :: ptr23, ptr32, ptr33 INTEGER :: cflg,i,p,diff,lng3 LOGICAL :: tri,loswitch * ----------- * initialise * ----------- grp1=' ' grp2=' ' grp3=' ' ptr11=0 ptr23=0 ptr33=0 lng3=0 tri = .false. loswitch = .false. * --------------------------------------- * found where parenthesis open and close * --------------------------------------- * set the pointers for the first pair of unequal parentheses: ptr12 = locat ptr21 = locat + 1 * search first group * ------------------ * ptr11 is location of '(' match for ')' of the first pair ')(': p = 1 DO i=ptr12-1,2,-1 IF (group(i:i).EQ.')') p = p + 1 IF (group(i:i).EQ.'(') p = p - 1 IF (p.EQ.0) THEN ptr11 = i GOTO 13 ENDIF ENDDO * if that point is reached, then error ... parenthesis mismatch WRITE(6,*) '--error--, in ckgrppt. First group of parenthesis ' WRITE(6,*) ' mismatch for the group :' WRITE(6,*) group WRITE(99,*) 'ckgrppt',group !STOP 13 CONTINUE * search second group * ------------------ * ptr23 is location of ')' match for '(' of the first pair ')(': p = 1 DO i = ptr21+1,lgr IF (group(i:i).EQ.'(') p = p + 1 IF (group(i:i).EQ.')') p = p - 1 IF (p.EQ.0) THEN ptr23 = i GO TO 17 ENDIF ENDDO * if that point is reached, then error ... parenthesis mismatch WRITE(6,*) '--error--, in ckgrppt. Second group of parenthesis ' WRITE(6,*) ' mismatch for the group :' WRITE(6,*) group WRITE(99,*) 'ckgrppt',group !STOP 17 CONTINUE * search third group (if any) * ------------------ * see if there are triple groups in parentheses instead * of a pair. PTR32 is *'(' and PTR33 is *')' of the third * group in parentheses. If no third group, then nothing is * expected after the second group of parentheses. ptr32 = ptr23 + 1 IF (group(ptr32:ptr32).EQ.'(') THEN tri = .true. p = 1 DO i=ptr32 + 1,lgr IF (group(i:i).EQ.')') p = p - 1 IF (group(i:i).EQ.'(') p = p + 1 IF(p.EQ.0) THEN ptr33 = i GOTO 25 ENDIF ENDDO * if that point is reached, then error ... parenthesis mismatch WRITE(6,*) '--error--, in ckgrppt. Third group of parenthesis ' WRITE(6,*) ' mismatch for the group :' WRITE(6,*) group WRITE(99,*) 'ckgrppt',group !STOP ELSE IF (group(ptr32:ptr32).NE.' '.AND. & group(ptr32:ptr32).NE.'.') THEN WRITE(6,*) '--error--, in ckgrppt. " " or "." is expected after' WRITE(6,*) ' second group of parenthesis in :' WRITE(6,*) group WRITE(99,*) 'ckgrppt',group !STOP ENDIF 25 CONTINUE * ----------------- * define all groups * ----------------- * 3 characters are sufficient to distinguish among the various * functional group and this 3 characters subset (grp(i)) are used to * define the priorities. Full group (grpi, includes the parenthesis) * are also identified to make the switches, if required. grp1 = group(ptr11:ptr12) grp(1) = group(ptr11+1:ptr11+3) grp2 = group(ptr21:ptr23) grp(2) = group(ptr21+1:ptr21+3) IF (tri) THEN grp3 = group(ptr32:ptr33) grp(3) = group(ptr32+1:ptr32+3) lng3 = ptr33 - ptr23 * check that nothing is after the third parenthesis IF (group(ptr33+1:ptr33+1).NE.' ') THEN WRITE(6,*) '--error--, in ckgrppt. A " " is expected after' WRITE(6,*) ' third group of parenthesis in :' WRITE(6,*) group WRITE(99,*)'ckgrppt',group !STOP ENDIF ENDIF * fluor is a special case, since it is only one character long: DO i=1,3 IF (grp(i)(1:1).EQ.'F') grp(i) = 'F ' ENDDO * -------------------------- * switch group, if necessary * -------------------------- * take and save what's sure tgroup = group(1:(ptr11 - 1)) * if the first two groups are wrongly placed then switch IF (INDEX(pri,grp(1)).LT.INDEX(pri,grp(2))) THEN loswitch=.true. ptr21 = ptr11 + (ptr23 - ptr12) tgroup(ptr11:lgr) = grp2 tgroup(ptr21:lgr) = grp1 IF (tri) tgroup(ptr32:lgr) = group(ptr32:lgr) group = tgroup ptr12 = ptr21 - 1 ENDIF * if there exists a third group and wrong placed then switch again IF (tri) THEN tgroup = ' ' * define if third group has higher priority than the two others: cflg = 0 DO i=1,2 IF (INDEX(pri,grp(i)).LT.INDEX(pri,grp(3))) cflg=cflg+1 ENDDO IF (cflg.EQ.1) THEN tgroup = group(1:ptr12) tgroup(ptr21:lgr) = grp3 IF (loswitch) THEN tgroup(ptr21+lng3:lgr) = grp1 ELSE tgroup(ptr21+lng3:lgr) = grp2 ENDIF group = tgroup ELSE IF (cflg.EQ.2) THEN tgroup = group(1:(ptr11 - 1)) tgroup(ptr11:lgr) = grp3 tgroup((ptr11 + lng3):lgr) = group(ptr11:ptr23) group = tgroup ENDIF ENDIF RETURN END