SUBROUTINE NORMAL (IUO, ITER, A, G, NX, LAWORK, GOOGE) *** FORM AND SOLVE NORMAL EQUATIONS IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) PARAMETER ( NVECS = 16 ) LOGICAL ADDOBS,OPENN,GETA,SOLVE LOGICAL LMSL,LSS,LUP DIMENSION IC(31),C(31) DIMENSION ICM((NVECS+1)*15+1) DIMENSION ISING(40),GSING(40) DIMENSION KINDS(3*NVECS),ISNS(3*NVECS),JSNS(3*NVECS),LOBS(3*NVECS) DIMENSION A(*),G(*),NX(*),GOOGE(*) COMMON /STRUCT/ NSTA,NAUX,NUNK,IDIM,NSTAS,NOBS,NCON,NZ,NCD COMMON /OPT/ AX,E2,DMSL,DGH,VM,VP,CTOL,ITMAX,ITMIN,IMODE, & LMSL,LSS,LUP COMMON /NUMVFS/ NVFTOT,NVFREE COMMON /VFTB2/ VFS(30),VTV(30),VFRN(30),VFSS(30) COMMON /ALICE/ IPRSZ *** SINGULARITY TOLERANCE STOL = 1.D-9 *** REWIND OBSERVATION EQUATIONS AND INITIALIZE NORMALS REWIND IUO IRANK = NUNK DENOM = ( IRANK * IRANK )/2.D0 INEED = NX(IRANK+1)+IRANK AVBW = 100.D0*( INEED )/DENOM IF (.NOT.OPENN(A,NX,IRANK,LAWORK)) THEN WRITE (*,20) LAWORK, INEED, IRANK 20 FORMAT (/, I9, ' DOUBLE PRECISION WORDS LESS THAN THE ', I9, & ' NEEDED FOR A RANK OF', I9, & /, ' INSUFFICIENT STORAGE -- FATAL!', /) WRITE (*,30) IDIM, NSTA, AVBW 30 FORMAT (/, ' THE AVERAGE BAND WIDTH FOR THE ', I1, & ' DIMENSIONAL ADJUSTMENT OF', I6, ' STATIONS', & ' WOULD BE ', F5.1, '%.') CALL ABORT2 ELSEIF (ITER .EQ. 0) THEN CALL LINE (2) WRITE (*,25) NSTA, IRANK, AVBW, INEED 25 FORMAT (/, ' THE AVERAGE BAND WIDTH FOR THE ', & ' 3-D ADJUSTMENT OF', I6, ' STATIONS', & ' AND RANK', I7, ' IS ', F5.1, '%.', & ' D.P. WORDS NEEDED=', I9) ENDIF *** LOAD OBSERVATION EQUATIONS AND FORM NORMALS 100 READ (IUO,END = 777) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME IF (KIND.LE.999) THEN EL = -CMO VAR = SD * SD IF (NVFTOT.GT.0 .AND. IVF.GT.0) VAR = VAR * VFS(IVF) P = 1.D0 / VAR IF ( .NOT.ADDOBS(C,IC,LENG,EL,P,A,NX) ) THEN WRITE (6,669) 669 FORMAT ('0PROFILE ERROR IN NORMAL') CALL ABORT2 ENDIF *** DECORRELATED TYPE ELSE NVEC = ISN LENG = (NVEC + 1) * 3 + 1 IF (NCD.GT.0) LENG = LENG + 12 * (NVEC + 1) NR = 3 * NVEC NC = NR + 5 + LENG READ (IUO,END = 666) ICM,NICM,KINDS,ISNS,JSNS,LOBS CALL GLOCAT (N1,N2,N3,N4,N5,NVEC,LENG) IF (NVFTOT.GT.0 .AND. IVF.GT.0) THEN P = 1.D0 / VFS(IVF) ELSE P = 1.D0 ENDIF DO 1 I = 1,NR READ (IUO,END = 666) ( G(J), J=1,NC ) EL = -G(N4) IF ( .NOT.ADDOBS( G(1+N2),ICM,NICM,EL,P,A,NX ) ) THEN WRITE (6,10) 10 FORMAT ('0ACCUM ERROR IN NORMAL') CALL ABORT2 ENDIF 1 CONTINUE ENDIF GO TO 100 777 CONTINUE *** INITIALIZE GOOGE NUMBERS DO 2 I = 1,NUNK IF ( .NOT.GETA(I,I,VAL,A,NX) ) THEN CALL INVIUN (I,ISN,ITYP,IUCODE) WRITE (6,3) I,ISN,ITYP 3 FORMAT ('0FATAL GOOGE ERROR IN NORMALS',3I5) CALL ABORT2 ELSE GOOGE(I) = VAL ENDIF 2 CONTINUE *** SOLVE THE NORMALS IF ( .NOT.SOLVE(A,NX,STOL,ISING,GSING,LSING) ) THEN IF (LSING.LE.0) THEN WRITE (6,668) 668 FORMAT ('0HOG STATE ERROR IN NORMAL') CALL ABORT2 ELSE CALL SINGUL (ISING,GSING,LSING,STOL) ENDIF ENDIF RETURN *** PREMATURE END OF FILE 666 WRITE (6,667) NVEC 667 FORMAT ('0ERROR - PREMATURE FILE END IN NORMAL -- NVEC = ',I5) CALL ABORT2 RETURN END SUBROUTINE SINGUL (ISING,GSING,LSING,STOL) *** FATAL TERMINATE DUE TO SINGULARITY IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) PARAMETER (MXSSN = 9999) LOGICAL GETSSN,INVZ,LOCSSN CHARACTER*30 NAME,NAMES DIMENSION ISING(*),GSING(*) COMMON /NAMTAB/ NAMES(MXSSN) CALL LINE (2) WRITE (6,1) LSING,STOL 1 FORMAT ('0ERROR - THE FOLLOWING',I3,' UNKNOWNS FALL BELOW', & ' TOLERANCE OF ',1PD8.2) DO 4 I = 1,LSING CALL INVIUN (ISING(I),ISN,ITYPE,IUCODE) *** SINGULAR COORDINATES IF (IUCODE.EQ.0) THEN IF ( .NOT.LOCSSN(ISN,ISSN) ) THEN WRITE (6,666) ISN 666 FORMAT ('0SSN TABLE ERROR IN SINGL--',I5) CALL ABORT2 ENDIF NAME = NAMES(ISN) IF (ITYPE.EQ.1) THEN CALL LINE (1) WRITE (6,11) I,ISSN,NAME,GSING(I) 11 FORMAT (1X,I2, I5,3X,A30, & ' NORTH/SOUTH SHIFT GOOGE NUMBER IS',1PD10.2) ELSEIF (ITYPE.EQ.2) THEN CALL LINE (1) WRITE (6,12) I,ISSN,NAME,GSING(I) 12 FORMAT (1X,I2, I5,3X,A30, & ' EAST/WEST SHIFT GOOGE NUMBER IS',1PD10.2) ELSEIF (ITYPE.EQ.3) THEN CALL LINE (1) WRITE (6,13) I,ISSN,NAME,GSING(I) 13 FORMAT (1X,I2, I5,3X,A30, & ' UP/DOWN SHIFT GOOGE NUMBER IS',1PD10.2) ELSE WRITE (6,3) ITYPE 3 FORMAT ('0ERROR - ILLEGAL TYPE CODE',I5) CALL ABORT2 ENDIF *** SINGULAR AUXILIARY PARAMETERS ELSEIF (IUCODE.EQ.1) THEN IAUX = ISN CALL LINE (1) WRITE (6,21) I,IAUX,GSING(I) 21 FORMAT (1X,I2,2X,'THE',I3,'-TH AUXILARY PARM. GOOGE', & ' NUMBER IS',1PD10.2) *** SINGULAR CRUSTAL DYNAMIC PARAMETERS ELSEIF (IUCODE.EQ.2) THEN CALL LINE (1) WRITE (6,41) I,ISN,GSING(I) 41 FORMAT (1X,I2,2X,'THE',I2,'-TH VELOCITY PARM. GOOGE', & ' NUMBER IS',1PD10.2) *** SINGULAR ROTATION PARAMETERS ELSEIF (IUCODE.EQ.3) THEN IZ = ISN IF ( .NOT.INVZ(IZ,ISSN,ILIST) ) THEN WRITE (6,32) I,IZ 32 FORMAT ('0ERROR - ILLEGAL ROTATION UNKNOWN IN SINGUL',2I5) CALL ABORT2 ELSEIF ( .NOT.GETSSN(ISSN,ISN) ) THEN WRITE (6,33) IZ,ISSN,ILIST 33 FORMAT ('0ERROR - ILLEGAL STATION SERIAL NUMBER IN SINGUL', & 3I5) ELSE NAME = NAMES(ISN) CALL LINE (1) WRITE (6,31) I,IZ,GSING(I),ILIST,NAME 31 FORMAT (1X,I2,2X,'THE',I5,'-TH ROT. UNK. GOOGE NUMBER IS', & 1PD10.2,' FOR LIST #',0P,I3,' AT ',A30) ENDIF ELSE WRITE (6,2) I,ISING(I),ISN,ITYPE,IUCODE 2 FORMAT ('0ERROR - ILLEGAL IUCODE IN SINGUL',5I5) CALL ABORT2 ENDIF 4 CONTINUE WRITE (6,5) 5 FORMAT ('0ERROR - THE ADJUSTMENT IS SINGULAR !! ',30('*') ) CALL ABORT2 RETURN END