changequote({,})changecom({!})dnl define({typename}, {ifelse(type, {DOUBLE}, {DOUBLE PRECISION}, type)})dnl ! Copyright (C) GFD Dennou Club, 2001. All rights reserved ! generator of anvargetreal, anvargetdouble, etc. SUBROUTINE ANVARGET{}type{}(VAR, START, CNT, STRIDE, IMAP, SIZ, VALUE, IOSTAT) USE AN_TYPES, ONLY: AN_VARIABLE USE AN_VARTABLE, ONLY: AN_VARIABLE_ENTRY, VTABLE_LOOKUP USE NETCDF_F77, ONLY: NF_NOERR, NF_EINVAL, NF_GET_VARM_{}type, & & NF_GET_VAR1_{}type USE DC_TRACE, ONLY: BEGINSUB, ENDSUB, MESSAGE IMPLICIT NONE TYPE(AN_VARIABLE), INTENT(IN):: VAR INTEGER, INTENT(IN):: START(:) INTEGER, INTENT(IN):: CNT(:) INTEGER, INTENT(IN):: STRIDE(:) INTEGER, INTENT(IN):: IMAP(:) INTEGER, INTENT(IN):: SIZ typename, INTENT(OUT):: VALUE(SIZ) INTEGER, INTENT(OUT):: IOSTAT INTEGER:: ND, IPOS, I TYPE(AN_VARIABLE_ENTRY):: ENT INTEGER, ALLOCATABLE:: ISTART(:), ISTRIDE(:), IIMAP(:) CONTINUE CALL BEGINSUB('anvarget{}type', & & FMT='varmap=%d, start=%*d, cnt=%*d, stride=%*d, imap=%*d siz=%d', & & I=(/VAR%ID, START(:), CNT(:), STRIDE(:), IMAP(:), SIZ/), & & N=(/SIZE(START), SIZE(CNT), SIZE(STRIDE), SIZE(IMAP)/)) IOSTAT = VTABLE_LOOKUP(VAR, ENT) IF (IOSTAT /= NF_NOERR) GOTO 999 ! --- ND CHECK --- ND = 0 IF (ASSOCIATED(ENT%DIMIDS)) ND = SIZE(ENT%DIMIDS) IF (MIN(SIZE(START), SIZE(CNT), SIZE(STRIDE), SIZE(IMAP)) < ND) THEN IOSTAT = NF_EINVAL GOTO 999 ENDIF IF (ND == 0) THEN IOSTAT = NF_GET_VAR1_{}type{}(ENT%FILEID, ENT%VARID, START, VALUE(1)) GOTO 999 ENDIF ! --- STRIDE KAKIKAE BUFFER --- ALLOCATE(ISTART(ND), ISTRIDE(ND), IIMAP(ND)) ISTART(1:ND) = START(1:ND) ISTRIDE(1:ND) = STRIDE(1:ND) IIMAP(1:ND) = IMAP(1:ND) IPOS = 1 ! --- DO READ --- IF (ENT%VARID <= 0 .OR. COUNT(CNT(1:ND) == 1) >= 0) THEN CALL BEGINSUB('fake_map_get') CALL FAKE_MAP_GET CALL ENDSUB('fake_map_get', 'iostat=%d', I=(/IOSTAT/)) ELSE ! NEGATIVE STRIDE IS NOT ALLOWED FOR NETCDF DO, I = 1, ND IF (STRIDE(I) > 0) CYCLE IPOS = IPOS + (CNT(I) - 1) * IMAP(I) ISTART(I) = START(I) + (CNT(I) - 1) * STRIDE(I) ISTRIDE(I) = -STRIDE(I) IIMAP(I) = -IMAP(I) CALL MESSAGE('DIM %D NEGATE: STRIDE->%D START->%D MAP->%D', & & I=(/I, ISTRIDE(I), ISTART(I), IIMAP(I)/)) ENDDO IOSTAT = NF_GET_VARM_{}type{}(ENT%FILEID, ENT%VARID, & & ISTART, CNT, ISTRIDE, IIMAP, VALUE(IPOS)) ENDIF DEALLOCATE(ISTART, ISTRIDE, IIMAP) 999 CONTINUE CALL ENDSUB('anvarget{}type', 'iostat=%d', I=(/IOSTAT/)) RETURN CONTAINS SUBROUTINE FAKE_MAP_GET INTEGER:: OFS(ND), HERE(ND) INTEGER:: J CONTINUE IOSTAT = NF_NOERR OFS(1:ND) = 0 DO J = IPOS + DOT_PRODUCT(OFS(1:ND), IMAP(1:ND)) HERE(1:ND) = ISTART(1:ND) + OFS(1:ND) * ISTRIDE(1:ND) IF (J < 1 .OR. J > SIZ) THEN IOSTAT = NF_EINVAL CALL MESSAGE('nf_get_var1_{}type{}(ncid=%d, varid=%d,& & indx=[%*d], out-ofs=%d)', & & I=(/ENT%FILEID, ENT%VARID, HERE(1:ND), J/), N=(/ND/)) RETURN ENDIF IF (ENT%VARID == 0) THEN VALUE(J) = J IOSTAT = NF_NOERR ELSE IOSTAT = NF_GET_VAR1_{}type{}(ENT%FILEID, ENT%VARID, & & HERE(1), VALUE(J)) ENDIF IF (IOSTAT /= NF_NOERR) RETURN OFS(1) = OFS(1) + 1 DO, J = 1, ND - 1 IF (OFS(J) < CNT(J)) EXIT OFS(J) = 0 OFS(J + 1) = OFS(J + 1) + 1 ENDDO IF (OFS(ND) >= CNT(ND)) EXIT ENDDO END SUBROUTINE END SUBROUTINE