diff options
Diffstat (limited to 'Ganlib/src/LCMNAN.f')
| -rw-r--r-- | Ganlib/src/LCMNAN.f | 218 |
1 files changed, 218 insertions, 0 deletions
diff --git a/Ganlib/src/LCMNAN.f b/Ganlib/src/LCMNAN.f new file mode 100644 index 0000000..3067042 --- /dev/null +++ b/Ganlib/src/LCMNAN.f @@ -0,0 +1,218 @@ +*DECK LCMNAN + SUBROUTINE LCMNAN(IPLIST) +* +*---------------------------------------------------------------------- +* +*Purpose: +* Scan a LCM object for NaN. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIST address of the table or handle to the XSM file. +* +*---------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIST +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXLEV=50) + CHARACTER NAMT*12,MYNAME*12,PATH(MAXLEV)*12,FIRST(MAXLEV)*12, + 1 NAMLCM*12,HSMG*131 + INTEGER IVEC(MAXLEV),KJLON(MAXLEV),IGO(MAXLEV) + TYPE(C_PTR) KDATA(MAXLEV) + LOGICAL EMPTY,LCM +*---- +* POINTER VARIABLES +*---- + TYPE(C_PTR) PT_DATA + REAL, POINTER :: RRR(:) + DOUBLE PRECISION, POINTER :: DDD(:) + COMPLEX, POINTER :: CCC(:) +* + ILEV=1 + KDATA(1)=IPLIST + KJLON(1)=-1 + IVEC(1)=1 + IGO(1)=5 + CALL LCMVAL(IPLIST,' ') + CALL LCMINF(IPLIST,NAMLCM,MYNAME,EMPTY,ILONG,LCM) + IF(EMPTY) GO TO 65 +* +* ASSOCIATIVE TABLE. + 10 NAMT=' ' + CALL LCMNXT(IPLIST,NAMT) + LENNAM=12 + IF(NAMT.EQ.' ') LENNAM=0 +* + FIRST(ILEV)=NAMT + 20 CALL LCMLEN(IPLIST,NAMT,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 60 + IF(ITYLCM.EQ.0) THEN +* ASSOCIATIVE TABLE DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LCMNAN: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',NAMLCM,'''(1).' + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=-1 + KDATA(ILEV)=LCMGID(IPLIST,NAMT) + PATH(ILEV)=NAMT + IPLIST=KDATA(ILEV) + IVEC(ILEV)=1 + IGO(ILEV)=1 + GO TO 10 + ELSE IF(ITYLCM.EQ.10) THEN +* LIST DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LCMNAN: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',NAMLCM,'''(2).' + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=ILONG + KDATA(ILEV)=LCMGID(IPLIST,NAMT) + PATH(ILEV)=NAMT + IPLIST=KDATA(ILEV) + IVEC(ILEV)=0 + IGO(ILEV)=2 + GO TO 70 + ELSE IF(ITYLCM.LE.6) THEN + CALL LCMGPD(IPLIST,NAMT,PT_DATA) + IF(ITYLCM.EQ.2) THEN +* SINGLE PRECISION DATA. + CALL C_F_POINTER(PT_DATA, RRR, (/ ILONG /)) + DO I=1,ILONG + IF(RRR(I).NE.RRR(I)) THEN + WRITE(HSMG,'(36HLCMNAN: NAN DETECTED IN REAL ARRAY: , + 1 A12)') NAMT + CALL XABORT(HSMG) + ENDIF + ENDDO + ELSE IF(ITYLCM.EQ.4) THEN +* DOUBLE PRECISION DATA. + CALL C_F_POINTER(PT_DATA, DDD, (/ ILONG /)) + DO I=1,ILONG + IF(DDD(I).NE.DDD(I)) THEN + WRITE(HSMG,'(38HLCMNAN: NAN DETECTED IN DOUBLE ARRAY: , + 1 A12)') NAMT + CALL XABORT(HSMG) + ENDIF + ENDDO + ELSE IF(ITYLCM.EQ.6) THEN +* COMPLEX DATA. + CALL C_F_POINTER(PT_DATA, CCC, (/ ILONG /)) + DO I=1,ILONG + IF(CCC(I).NE.CCC(I)) THEN + WRITE(HSMG,'(39HLCMNAN: NAN DETECTED IN COMPLEX ARRAY: , + 1 A12)') NAMT + CALL XABORT(HSMG) + ENDIF + ENDDO + ENDIF + ELSE + WRITE(HSMG,'(34HLCMNAN: UNKNOWN TYPE RECORD NAMED ,A12, + 1 5H (1).)') NAMLCM + CALL XABORT(HSMG) + ENDIF + GO TO 60 +* + 55 NAMT=PATH(ILEV) + ILEV=ILEV-1 + IPLIST=KDATA(ILEV) +* + 60 CALL LCMNXT(IPLIST,NAMT) + IF(NAMT.NE.FIRST(ILEV)) GO TO 20 + 65 GO TO (55,55,95,95,100),IGO(ILEV) +* +* LIST. + 70 IVEC(ILEV)=IVEC(ILEV)+1 + IF(IVEC(ILEV).GT.KJLON(ILEV)) THEN + GO TO (55,55,95,95,100),IGO(ILEV) + ENDIF + CALL LCMLEL(KDATA(ILEV),IVEC(ILEV),ILONG,ITYLCM) + IF((ILONG.NE.0).AND.(ITYLCM.EQ.0)) THEN +* ASSOCIATIVE TABLE DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LCMNAN: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',NAMLCM,'''(3).' + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=-1 + KDATA(ILEV)=LCMGIL(IPLIST,IVEC(ILEV-1)) + IPLIST=KDATA(ILEV) + IVEC(ILEV)=1 + IGO(ILEV)=3 + GO TO 10 + ELSE IF((ILONG.NE.0).AND.(ITYLCM.EQ.10)) THEN +* LIST DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LCMNAN: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',NAMLCM,'''(4).' + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=ILONG + KDATA(ILEV)=LCMGIL(IPLIST,IVEC(ILEV-1)) + IPLIST=KDATA(ILEV) + IVEC(ILEV)=0 + IGO(ILEV)=4 + GO TO 70 + ELSE IF((ILONG.NE.0).AND.(ITYLCM.LE.6)) THEN + CALL LCMGPL(IPLIST,IVEC(ILEV),PT_DATA) + IF(ITYLCM.EQ.2) THEN +* SINGLE PRECISION DATA. + CALL C_F_POINTER(PT_DATA, RRR, (/ ILONG /)) + DO I=1,ILONG + IF(RRR(I).NE.RRR(I)) THEN + WRITE(HSMG,'(36HLCMNAN: NAN DETECTED IN REAL ARRAY: , + 1 I12)') IVEC(ILEV) + CALL XABORT(HSMG) + ENDIF + ENDDO + ELSE IF(ITYLCM.EQ.4) THEN +* DOUBLE PRECISION DATA. + CALL C_F_POINTER(PT_DATA, DDD, (/ ILONG /)) + DO I=1,ILONG + IF(DDD(I).NE.DDD(I)) THEN + WRITE(HSMG,'(38HLCMNAN: NAN DETECTED IN DOUBLE ARRAY: , + 1 I12)') IVEC(ILEV) + CALL XABORT(HSMG) + ENDIF + ENDDO + ELSE IF(ITYLCM.EQ.6) THEN +* COMPLEX DATA. + CALL C_F_POINTER(PT_DATA, CCC, (/ ILONG /)) + DO I=1,ILONG + IF(CCC(I).NE.CCC(I)) THEN + WRITE(HSMG,'(39HLCMNAN: NAN DETECTED IN COMPLEX ARRAY: , + 1 I12)') IVEC(ILEV) + CALL XABORT(HSMG) + ENDIF + ENDDO + ENDIF + ELSE IF(ILONG.NE.0) THEN + WRITE(HSMG,'(34HLCMNAN: UNKNOWN TYPE RECORD NAMED ,A12, + 1 5H (2).)') NAMLCM + CALL XABORT(HSMG) + ENDIF + GO TO 70 +* + 95 ILEV=ILEV-1 + IPLIST=KDATA(ILEV) + GO TO 70 +* + 100 WRITE(6,'(25H LCMNAN: NO NaN DETECTED.)') + RETURN + END + |